How to track number of clients with Indy TIdTCPServer - delphi

I want to know the number of current client connections to an Indy 9 TIdTCPServer (on Delphi 2007)
I can't seem to find a property that gives this.
I've tried incrementing/decrementing a counter on the server OnConnect/OnDisconnect events, but the number never seems to decrement when a client disconnects.
Any suggestions?

The currently active clients are stored in the server's Threads property, which is a TThreadList. Simply lock the list, read its Count property, and then unlock the list:
procedure TForm1.Button1Click(Sender: TObject);
var
NumClients: Integer;
begin
with IdTCPServer1.Threads.LockList do try
NumClients := Count;
finally
IdTCPServer1.Threads.UnlockList;
end;
ShowMessage('There are currently ' + IntToStr(NumClients) + ' client(s) connected');
end;
In Indy 10, the Threads property was replaced with the Contexts property:
procedure TForm1.Button1Click(Sender: TObject);
var
NumClients: Integer;
begin
with IdTCPServer1.Contexts.LockList do try
NumClients := Count;
finally
IdTCPServer1.Contexts.UnlockList;
end;
ShowMessage('There are currently ' + IntToStr(NumClients) + ' client(s) connected');
end;

Not sure why using OnConnect and OnDisconnect wouldn't work for you, but what we have done is to create a descendant of TIdCustomTCPServer; to override its DoConnect and DoDisconnect methods and create and use our own descendant of TIdServerContext (a thread descendant that will "serve" a connection).
You make the TIdCustomTCPServer aware of your own TIdServerContext class by:
(Edit Added conditional defines to show how to make it work for Indy9)
type
// Conditional defines so that we can use the same ancestors as in Indy10 and we
// can use the same method signatures for DoConnect and DoDisconnect regardless
// of the Indy version. Add other conditional defines as needed.
// Note: for INDY9 to be defined, you need to include the appropriate includes
// from Indy, or define it in your own include file.
{$IFDEF INDY9}
TIdContext = TIdPeerThread;
TIdServerContext = TIdContext;
TIdCustomTCPServer = TIdTCPServer;
{$ENDIF}
TOurContext = class(TIdServerContext)
private
FConnectionId: cardinal;
public
property ConnectionId: cardinal ...;
end;
...
constructor TOurServer.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
...
{$IFDEF INDY10_UP}
ContextClass := TOurContext;
{$ELSE}
ThreadClass := TOurContext;
{$ENDIF}
...
end;
In the DoConnect override of our TIdCustomTCPServer descendant we set the ConnectionID of our context class to a unique value:
procedure TOurServer.DoConnect(AContext: TIdContext);
var
OurContext: TOurContextabsolute AContext;
begin
Assert(AContext is TOurContext);
HandleGetNewConnectionID(OurContext, OurContext.FConnectionID);
inherited DoConnect(AContext);
...
end;
Our DoDisconnect override clears the ConnectionID:
procedure TOurServer.DoDisconnect(AContext: TIdContext);
var
OurContext: TOurContextabsolute AContext;
begin
Assert(AContext is TOurContext);
OurContext.FConnectionID := 0;
...
inherited DoDisconnect(AContext);
end;
Now it is possible to get a count of the current connections at any time:
function TOurServer.GetConnectionCount: Integer;
var
i: Integer;
CurrentContext: TOurContext;
ContextsList: TList;
begin
MyLock.BeginRead;
try
Result := 0;
if not Assigned(Contexts) then
Exit;
ContextsList := Contexts.LockList;
try
for i := 0 to ContextsList.Count - 1 do
begin
CurrentContext := ContextsList[i] as TOurContext;
if CurrentContext.ConnectionID > 0 then
Inc(Result);
end;
finally
Contexts.UnLockList;
end;
finally
MyLock.EndRead;
end;
end;

How about incrementing / decrementing a counter from OnExecute (or DoExecute if you override that)? That can't go wrong!
If you use InterlockedIncrement and InterlockedDecrement you don't even need a critical section to protect the counter.

This should work on Indy 9, but it is pretty outdated nowadays, and maybe something is broken in your version, try to update to the latest Indy 9 available.
I made a simple test using Indy 10, which works very well with a simple interlocked Increment/Decrement in the OnConnect/OnDisconnect event handlers. This is my code:
//closes and opens the server, which listens at port 1025, default values for all properties
procedure TForm2.Button1Click(Sender: TObject);
begin
IdTCPServer1.Active := not IdTCPServer1.Active;
UpdateUI;
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
UpdateUI;
end;
//Just increment the count and update the UI
procedure TForm2.IdTCPServer1Connect(AContext: TIdContext);
begin
InterlockedIncrement(FClientCount);
TThread.Synchronize(nil, UpdateUI);
end;
//Just decrement the count and update the UI
procedure TForm2.IdTCPServer1Disconnect(AContext: TIdContext);
begin
InterlockedDecrement(FClientCount);
TThread.Synchronize(nil, UpdateUI);
end;
//Simple 'X' reply to any character, A is the "command" to exit
procedure TForm2.IdTCPServer1Execute(AContext: TIdContext);
begin
AContext.Connection.IOHandler.Writeln('Write anything, but A to exit');
while AContext.Connection.IOHandler.ReadByte <> 65 do
AContext.Connection.IOHandler.Write('X');
AContext.Connection.IOHandler.Writeln('');
AContext.Connection.IOHandler.Writeln('Good Bye');
AContext.Connection.Disconnect;
end;
//Label update with server status and count of connected clients
procedure TForm2.UpdateUI;
begin
Label1.Caption := Format('Server is %s, %d clients connected', [
IfThen(IdTCPServer1.Active, 'Open', 'Closed'), FClientCount]);
end;
then, opening a couple of clients with telnet:
then, closing one client
That's it.
INDY 10 is available for Delphi 2007, my main advise is to upgrade anyway.

Related

how to retain connections between controls when copying?

i want to ask how to retain controlls when im making a copy of a control. for example i have an edit box that can be controlled with a slider for value change. when i make a copy using this code i achieve a copy of the items but the slider stops controlling editbox values. how can i fix that?
TypInfo;
procedure CloneProperties(const Source: TControl; const Dest: TControl);
var
ms: TMemoryStream;
OldName: string;
begin
OldName := Source.Name;
Source.Name := ''; // needed to avoid Name collision
try
ms := TMemoryStream.Create;
try
ms.WriteComponent(Source);
ms.Position := 0;
ms.ReadComponent(Dest);
finally
ms.Free;
end;
finally
Source.Name := OldName;
end;
end;
procedure CloneEvents(Source, Dest: TControl);
var
I: Integer;
PropList: TPropList;
begin
for I := 0 to GetPropList(Source.ClassInfo, [tkMethod], #PropList) - 1 do
SetMethodProp(Dest, PropList[I], GetMethodProp(Source, PropList[I]));
end;
procedure DuplicateChildren(const ParentSource: TWinControl;
const WithEvents: Boolean = True);
var
I: Integer;
CurrentControl, ClonedControl: TControl;
begin
for I := ParentSource.ControlCount - 1 downto 0 do
begin
CurrentControl := ParentSource.Controls[I];
ClonedControl := TControlClass(CurrentControl.ClassType).Create(CurrentControl.Owner);
ClonedControl.Parent := ParentSource;
CloneProperties(CurrentControl, ClonedControl);
ClonedControl.Name := CurrentControl.Name + '_';
if WithEvents then
CloneEvents(CurrentControl, ClonedControl);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
DuplicateChildren(Panel1);
end;
Unless I'm misunderstanding you, your CloneProperties doesn't seem to have anything to do with the question you're asking. In your example of an edit control E1 and a slider S1, you can clone both of them to produce E2 and S2, but somewhere in your code there must be a statement that changes the value in E1 depending on the value of S1. However, in the way you've most likely written it, that statement doesn't apply to E2 and S2.
The simplest way around that is to write a method which takes the component instances and links the operation of the two together. e.g.
procedure TForm1.SetEditControlFromSlider(AnEdit : TEdit; ASlider : { TWhatever the slider actually is);
begin
// Set AnEdit's value from ASlider's properties
end;
Then, you can call this with Edit/Slider pairs like this
SetEditControlFromSlider(E1, S1);
[...]
SetEditControlFromSlider(E2, S2);
I can imagine you might not like having to do that.
IMO, the cleanest solution is to avoid attempting to clone components altogether and create a TFrame containing the Edit, Slider and the code that connects them, and then add to your form as many instances of the frame as you need. It's as easy as falling off a log.
type
TEditFrame = class(TFrame) // needs to be in its own unit, Used by your form
Edit1: TEdit;
TrackBar1: TTrackBar;
procedure TrackBar1Change(Sender: TObject);
private
public
end;
[...]
procedure TEditFrame.TrackBar1Change(Sender: TObject);
begin
Edit1.Text := IntToStr(TrackBar1.Position)
end;
Then, you can add clones of the frame to TForm1 by
procedure TForm1.Button1Click(Sender: TObject);
var
AFrame : TEditFrame;
begin
Inc(FrameCount); // Field of TForm1
AFrame := TEditFrame.Create(Self);
AFrame.Name := AFrame.Name + IntToStr(FrameCount);
AFrame.Parent := Self;
AFrame.Top := AFrame.Height * FrameCount;
end;
Note that because the code which links the two components, TrackBar1Change, it compiled into the frame's unit, it is automatically shared by every instance of the frame you create, without any need to "clone" the code.

Looping without causing app to freeze

I would like to write a loop that checks the value of a variable has changed. There's no event that fires to tell me the value has changed.
The application doesn't support multi threading.
How to achieve this without causing app to freeze ?
The aim is this:
Application starts
...
loop
Check variable value
If changed then
exit
if timedOut then
exit
While loop causes application to freeze.
Thank you.
* Edit *
This is what I'm after (this code is written by Remy Lebeau):
const
APPWM_COM_EVENT_DONE = WM_APP + 1;
APPWM_COM_EVENT_TIMEOUT = WM_APP + 2;
type
MyClass = class
private
MsgWnd: HWND;
procedure COMEventHandler(parameters);
procedure WndProc(var Message: TMessage);
public
constructor Create;
destructor Destroy; override;
procedure DoIt;
end;
constructor MyClass.Create;
begin
inherited;
MsgWnd := AllocateHWnd(WndProc);
end
destructor MyClass.Destroy;
begin
KillTimer(MsgWnd, 1);
DeallocateHWnd(MsgWnd);
inherited;
end;
procedure MyClass.COMEventHandler(parameters);
begin
KillTimer(MsgWnd, 1);
PostMessage(MsgWnd, APPWM_COM_EVENT_DONE, 0, 0);
end;
procedure MyTimer(hWnd: HWND; uMsg: UINT; idEvent: UINT_PTR; dwTime: DWORD); stdcall;
begin
KillTimer(hWnd, idEvent);
PostMessage(hWnd, APPWM_COM_EVENT_TIMEOUT, 0, 0);
end;
procedure MyClass.WndProc(var Message: TMessage);
begin
case Message.Msg of
APPWM_COM_EVENT_DONE:
begin
// Event fired, all good
end;
APPWM_COM_EVENT_TIMEOUT:
begin
// Event timed out
end;
else
begin
Message.Result := DefWindowProc(MsgWnd, Message.Msg, Message.WParam, Message.LParam);
end;
end;
end;
procedure MyClass.DoIt;
begin
SetTimer(MsgWnd, 1, 1000 * 1000, #MyTimer);
// invoke COM function that will eventually trigger the COM event...
end;
How to call DoIt and wait for either Event to fire or timeout without causing the application to freeze ?
Tried using while do loop but that prevented WndProc from running.
Thank you
Answer depends on your application demands. There are 2 easy solutions with prons and cons each:
1. Put Timer to application and check value by timeout. Dignity - it is the most easy way for GUI application (Windows messages loop already exists), drawback on other side - there will be delta time of detecting value have been changed.
2. Handle Application.OnIdle event. Disadvantage of this approach - yor checking procedure will be runned if nobody click on GUI elements.
Professional way to solve your solution - wrap your variable by complex object, for example:
Trigger = class
private
FOnChanged: TNotifyEvent;
public
procedure Emit;
property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
end;
procedure Trigger.Emit;
if Assined(FOnChanged) then
FOnChanged(Self)
end;
Cause of your application has not threads we can implement Trigger without mutexes/critical sections, on another side you can handle changing as soon as event producer will raise Emit
Good approach if you don't want use multithreading is split your ligic on multiple state machines based on coroutines.
Example based on AIO framework https://github.com/Purik/AIO
AIO framework create itself events loop, scheduling multiple state machines in parallel without threads:
program TriggerExample;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
SyncObjs,
Gevent,
Greenlets;
const
WAIT_TMEOUT_MSEC = 1000;
var
ChangedEvent: TGevent;
Value: Boolean = False;
// Part of application that raise change events randomly
procedure EventsProducer;
begin
while True do
begin
Greenlets.GreenSleep(100+Random(10000));
Value := True;
ChangedEvent.SetEvent;
end;
end;
begin
ChangedEvent := TGevent.Create(False, False);
// run fake event producer inside other state machine
TSymmetric.Spawn(EventsProducer);
// Loop
while True do
begin
if ChangedEvent.WaitFor(WAIT_TMEOUT_MSEC) = wrSignaled then
begin
WriteLn('Value was changed');
Value := False
end
else
begin
WriteLn('Exit by timeout');
end;
end;
end.

TIdHttp freezes when the internet gets slower

How to avoid freezing the idHTTP when the internet become slower or no connectivity. My application get freeze and I could not even close the form.
This is how I setup my code
procedure TDownloader.IdHTTPWork(ASender: TObject; AWorkMode: TWorkMode;
AWorkCount: Int64);
var
lwElapsedMS: LongWord;
iBytesTransferred: Int64;
iBytesPerSec: Int64;
iRemaining: Integer;
begin
if AWorkMode <> wmRead then Exit;
lwElapsedMS := GetTickDiff(FLastTicks, Ticks);
if lwElapsedMS = 0 then lwElapsedMS := 1; // avoid EDivByZero error
if FTotalBytes > 0 then
FPercentDone := Round(AWorkCount / FTotalBytes * 100.0)
else
FPercentDone := 0;
iBytesTransferred := AWorkCount - FLastWorkCount;
iBytesPerSec := Round(iBytesTransferred * 1000 / lwElapsedMS);
if Assigned(OnDownloadProgress) then
begin
if FContinueDownload <> 0 then //previous file downloaded
begin
iRemaining := 100 - FContinueDownload;
iRemaining := Round(FPercentDone * iRemaining / 100);
OnDownloadProgress(Self, FContinueDownload + iRemaining, AWorkCount, FTotalBytes, iBytesPerSec);
end else
OnDownloadProgress(Self, FPercentDone, AWorkCount, FTotalBytes, iBytesPerSec);
end;
FLastWorkCount := AWorkCount;
FLastTicks := Ticks;
if FCancel then
begin
Abort;
TidHttp(ASender).Disconnect;
end;
end;
procedure TDownloader.IdHTTPWorkBegin(ASender: TObject; AWorkMode: TWorkMode;
AWorkCountMax: Int64);
begin
if AWorkMode <> wmRead then Exit;
FPercentDone := 0;
FTotalBytes := AWorkCountMax;
FLastWorkCount := 0;
FLastTicks := Ticks;
end;
procedure TDownloader.IdHTTPWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
begin
if AWorkMode <> wmRead then Exit;
if Assigned(OnDownloadComplete) and (FPercentDone >= 100) then
OnDownloadComplete(Self)
else if Assigned(OnDownloadCancel) then
OnDownloadCancel(Self);
end;
function TDownloader.EXDownload(AURL, ADestFile: String;
AAutoDisconnect: Boolean): Boolean;
var
fsBuffer: TFileStream;
idHttp: TIdHttp;
begin
if FileExists(ADestFile) then
fsBuffer := TFileStream.Create(ADestFile, fmOpenReadWrite)
else
fsBuffer := TFileStream.Create(ADestFile, fmCreate);
fsBuffer.Seek(0, soFromEnd);
try
idHttp := TIdHttp.Create(nil);
idHttp.OnWorkBegin := idHttpWorkBegin;
idHttp.OnWork := idHttpWork;
idHttp.OnWorkEnd := idHttpWorkEnd;
idHttp.Request.CacheControl := 'no-store';
try
...
idHttp.Get(AURL, fsBuffer);
...
finally
idHttp.Free;
end;
finally
fsBuffer.Free;
end;
end;
......
procedure TDownloader.Execute;
begin
Inherited;
while not Terminated do
begin
if FUrl <> '' then
begin
EXDownload(FUrl, FFilename, True);
end;
end;
end;
...
on the main form progress
procedure TfrmDownloadList.DownloadProgress(Sender: TObject; aPercent:Integer;
aProgress, aProgressMax, aBytesPerSec: Int64);
var
yts: PYoutubeSearchInfo;
begin
if Assigned(FCurrentDownload) then
begin
yts := vstList.GetNodeData(FCurrentDownload);
yts.Tag := aPercent;
ProgressBar.Position := aPercent;
vstList.InvalidateNode(FCurrentDownload);
StatusBar.Panels.Items[1].Text := 'Download: ' + FormatByteSize(aProgress) + '/' +
FormatByteSize(aProgressMax);
StatusBar.Panels.Items[2].Text := 'Speed: ' + FormatByteSize(aBytesPerSec) + 'ps';
Application.ProcessMessages;
end;
end;
I don't have problem when the internet is good only when it drops due to poor signal.
this is my app lookslike
If we assume that TDownloader.OnDownloadProgress is assigned to the TfrmDownloadList.DownloadProgress method, then your problem is that you are calling VCL code (your update of the progress bar) from a secondary thread (ie. not from the Main thread). This is not supported.
You'll need to wrap the call with a Synchronize statement from within your thread. Synchronize calls a parameterless method on the main thread. So you need to store the variables that are needed and then call Synchronize on a method in your TDownloader class that then calls on to TfrmDownloadList.DownloadProgress
You cannot call TfrmDownloadList.DownloadProgress directly or indirectly from within code that runs on another thread than the main thread, as it updates VCL objects, and the VCL is not thread-safe.
The same goes for your DownloadComplete event, if it updates any VCL objects...
How about you using TIdAntiFreeze ?
TIdAntiFreeze implements a GUI-integration class that ensures
processor time is allocated for the Application main thread.
Indy works on the blocking sockets model. Calls made to methods in the
Indy components do not return until they are complete. If calls are
made in the main thread, this will cause the Application User
Interface to "freeze" during Indy calls. TIdAntiFreeze counteracts
this effect.
TIdAntiFreeze allows Indy to process Application messages so that
Windows messages continue to be executed while Indy blocking socket
calls are in effect.
Only one TIdAntiFreeze can be active in an application.

Execute a method from a form created by class reference (Delphi)

I have a form (form2) and I implemented the following PUBLIC method:
function ShowInterface(i:integer):boolean;
This form is in a package that will be DYNAMIC LOADED. Now I want to instantiate this form (form2) and execute the method above.
Important: I can't reference form2's unit in form1.
I tryed this code, but it never finds "ShowInterface" pointer (returns nil).
procedure TfrmForm1.Button1Click(Sender: TObject);
var
PackageModule: HModule;
AClass: TPersistentClass;
ShowInterface: function (i:integer):boolean;
frm: TCustomForm;
begin
PackageModule := LoadPackage('form2.bpl');
if PackageModule <> 0 then
begin
AClass := GetClass('TfrmForm2');
if AClass <> nil then // <<-- FINE!! IT FINDS OUT 'TfrmForm2' in 'form2.bpl')
begin
frm := TComponentClass(AClass).Create(Self) as TCustomForm;
ShowInterface := frm.MethodAddress('ShowInterface'); // <<-- HERE!! ALLWAYS RETURNS "NIL"
if #ShowInterface <> nil then
ShowInterface(1);
// but if I call frm.Show, it works fine. frm is "loaded"!!!
frm.Free;
end;
DoUnloadPackage(PackageModule);
end;
end;
Thanks in advance.
MethodAddress only works for published methods. Move it to the published section and it should work.
Or, if you have Delphi 2010, the extended RTTI offers a way to find public methods by name. (Or other visibility levels, if you change it from the default.)
As Mason and TOndrej said, I have to put the method in published section. (Thank you!)
But, some fixes were needed:
procedure TfrmForm1.Button1Click(Sender: TObject);
type
TShowInterface = function(i:integer):boolean of object;
var
PackageModule: HModule;
AClass: TPersistentClass;
Routine: TMethod;
ShowInterface : TShowInterface;
frm: TCustomForm;
begin
PackageModule := LoadPackage('form2.bpl');
if PackageModule <> 0 then
begin
AClass := GetClass('TfrmForm2');
if AClass <> nil then
begin
frm := TComponentClass(AClass).Create(Self) as TCustomForm;
Routine.Data := Pointer(frm);
Routine.Code := frm.MethodAddress('ShowInterface');
if Assigned(Routine.Code) then
begin
ShowInterface := TShowInterface(Routine);
ShowInterface(1); // showinterface executes a "ShowModal", so we can "free" form after this.
end;
frm.Free;
end;
DoUnloadPackage(PackageModule);
end;
end;
In D2007 and some earlier versions, that only works with published methods, or extended RTTI: {$METHODINFO ON}. I haven't used D2010 yet; it seems to have a new RTTI system which has been extended a lot.

How to consume in process server method with DataSnap 2010

I define a server method:
TServerMethod = class(TPersistent)
public
function EchoString(Value: string): string;
end;
The method EchoString return an equivalent Value string.
I then use TDSTCPServerTransport with TDSServer and TDSServerClass to wrap the server methods.
In client side, I create a DataSnap TSQLConnection and generate a TServerMethodProxy client class:
function TServerMethodClient.EchoString(Value: string): string;
begin
if FEchoStringCommand = nil then
begin
FEchoStringCommand := FDBXConnection.CreateCommand;
FEchoStringCommand.CommandType := TDBXCommandTypes.DSServerMethod;
FEchoStringCommand.Text := 'TServerMethod.EchoString';
FEchoStringCommand.Prepare;
end;
FEchoStringCommand.Parameters[0].Value.SetWideString(Value);
FEchoStringCommand.ExecuteUpdate;
Result := FEchoStringCommand.Parameters[1].Value.GetWideString;
end;
I able to consume the EchoString method via TCP connection in client application:
var o: TServerMethodClient;
begin
o := TSeverMethodClient.Create(SQLConnection1.DBXConnection);
try
ShowMessage(o.EchoString('Hello'));
finally
o.Free;
end;
end;
The above scenarios is using TCP/IP as communication protocol.
However, I wish to deploy my ServerMethod together with my client as "In Process" model. How can I achieve that without changing my client and server method code?
What parameter should I pass to TServerMethodClient.Create constructor in order to establish a in process connection?
o := TSeverMethodClient.Create(SQLConnection1.DBXConnection);
In old DataSnap day, we can use TLocalConnection to enjoy In Process access without changing both client and server codes.
DataSnap Server Method was introduced in Delphi 2009. Most video or demo about DataSnap server method available only introduce socket based client server access communication. e.g.: TCP or HTTP protocol.
However, DataSnap was designed as a scalable data access solution that able to work with one, two, three or more tiers model. All examples we see so far are suitable for 2 or 3 tiers design. I can’t find any example talking about 1 tier or in-process design.
Indeed, it is very simple to work with in-process server method. Most steps are similar to out-of-process server methods.
Define a Server Method
Define a well known EchoString() and a Sum() server method:
unit MyServerMethod;
interface
uses Classes, DBXCommon;
type
{$MethodInfo On}
TMyServerMethod = class(TPersistent)
public
function EchoString(Value: string): string;
function Sum(const a, b: integer): integer;
end;
{$MethodInfo Off}
implementation
function TMyServerMethod.EchoString(Value: string): string;
begin
Result := Value;
end;
function TMyServerMethod.Sum(const a, b: integer): integer;
begin
Result := a + b;
end;
end.
Define a DataModule to access the server method
Drop a TDSServer and TDSServerClass as usual to the data module. Define a OnGetClass event to TDSServerClass instance. Please note that you don’t need to drop any transport components like TDSTCPServerTransport or TDSHTTPServer as we only want to consume the server method for in-process only.
object MyServerMethodDataModule1: TMyServerMethodDataModule
OldCreateOrder = False
Height = 293
Width = 419
object DSServer1: TDSServer
AutoStart = True
HideDSAdmin = False
Left = 64
Top = 40
end
object DSServerClass1: TDSServerClass
OnGetClass = DSServerClass1GetClass
Server = DSServer1
LifeCycle = 'Server'
Left = 64
Top = 112
end
end
unit MyServerMethodDataModule;
uses MyServerMethod;
procedure TMyServerMethodDataModule.DSServerClass1GetClass(
DSServerClass: TDSServerClass; var PersistentClass: TPersistentClass);
begin
PersistentClass := TMyServerMethod;
end;
Generate Server Method Client Classes
It is not easy to generate the server method client classes design for in-process server. You may try any methods you are familiar with to hook up your server method to TCP or HTTP transport service, start the service and attempt to generate the client class by any means.
//
// Created by the DataSnap proxy generator.
//
unit DataSnapProxyClient;
interface
uses DBXCommon, DBXJSON, Classes, SysUtils, DB, SqlExpr, DBXDBReaders;
type
TMyServerMethodClient = class
private
FDBXConnection: TDBXConnection;
FInstanceOwner: Boolean;
FEchoStringCommand: TDBXCommand;
public
constructor Create(ADBXConnection: TDBXConnection); overload;
constructor Create(ADBXConnection: TDBXConnection; AInstanceOwner: Boolean); overload;
destructor Destroy; override;
function EchoString(Value: string): string;
function Sum(const a, b: integer): integer;
end;
implementation
function TMyServerMethodClient.EchoString(Value: string): string;
begin
if FEchoStringCommand = nil then
begin
FEchoStringCommand := FDBXConnection.CreateCommand;
FEchoStringCommand.CommandType := TDBXCommandTypes.DSServerMethod;
FEchoStringCommand.Text := 'TMyServerMethod.EchoString';
FEchoStringCommand.Prepare;
end;
FEchoStringCommand.Parameters[0].Value.SetWideString(Value);
FEchoStringCommand.ExecuteUpdate;
Result := FEchoStringCommand.Parameters[1].Value.GetWideString;
end;
function TMyServerMethodClient.Sum(a: Integer; b: Integer): Integer;
begin
if FSumCommand = nil then
begin
FSumCommand := FDBXConnection.CreateCommand;
FSumCommand.CommandType := TDBXCommandTypes.DSServerMethod;
FSumCommand.Text := 'TMyServerMethod.Sum';
FSumCommand.Prepare;
end;
FSumCommand.Parameters[0].Value.SetInt32(a);
FSumCommand.Parameters[1].Value.SetInt32(b);
FSumCommand.ExecuteUpdate;
Result := FSumCommand.Parameters[2].Value.GetInt32;
end;
constructor TMyServerMethodClient.Create(ADBXConnection: TDBXConnection);
begin
inherited Create;
if ADBXConnection = nil then
raise EInvalidOperation.Create('Connection cannot be nil. Make sure the connection has been opened.');
FDBXConnection := ADBXConnection;
FInstanceOwner := True;
end;
constructor TMyServerMethodClient.Create(ADBXConnection: TDBXConnection; AInstanceOwner: Boolean);
begin
inherited Create;
if ADBXConnection = nil then
raise EInvalidOperation.Create('Connection cannot be nil. Make sure the connection has been opened.');
FDBXConnection := ADBXConnection;
FInstanceOwner := AInstanceOwner;
end;
destructor TMyServerMethodClient.Destroy;
begin
FreeAndNil(FEchoStringCommand);
inherited;
end;
end.
Invoke the server method via in-process
You may see from the following code that there is no different to access the server method for in-process and out-of-process design.
First, you create an instant of datasnap server. This will register the DSServer to the TDBXDriverRegistry. e.g. DSServer1 in this case.
You may then use TSQLConnection with DSServer1 as driver name instead of “DataSnap” that require socket connection to initiate in-process communication invoking the server method.
var o: TMyServerMethodDataModule;
Q: TSQLConnection;
c: TMyServerMethodClient;
begin
o := TMyServerMethodDataModule.Create(Self);
Q := TSQLConnection.Create(Self);
try
Q.DriverName := 'DSServer1';
Q.LoginPrompt := False;
Q.Open;
c := TMyServerMethodClient.Create(Q.DBXConnection);
try
ShowMessage(c.EchoString('Hello'));
finally
c.Free;
end;
finally
o.Free;
Q.Free;
end;
end;
Troubleshoot: Encounter Memory Leak after consume the in-process server methods
This happens in Delphi 2010 build 14.0.3513.24210. It may have fixed in future release. You may check QC#78696 for latest status. Please note that you need to add “ReportMemoryLeaksOnShutdown := True;” in the code to show the leak report.
The memory leaks has no relation with in-process server methods. It should be a problem in class TDSServerConnection where a property ServerConnectionHandler doesn’t free after consume.
Here is a fix for the problem:
unit DSServer.QC78696;
interface
implementation
uses SysUtils,
DBXCommon, DSServer, DSCommonServer, DBXMessageHandlerCommon, DBXSqlScanner,
DBXTransport,
CodeRedirect;
type
TDSServerConnectionHandlerAccess = class(TDBXConnectionHandler)
FConProperties: TDBXProperties;
FConHandle: Integer;
FServer: TDSCustomServer;
FDatabaseConnectionHandler: TObject;
FHasServerConnection: Boolean;
FInstanceProvider: TDSHashtableInstanceProvider;
FCommandHandlers: TDBXCommandHandlerArray;
FLastCommandHandler: Integer;
FNextHandler: TDBXConnectionHandler;
FErrorMessage: TDBXErrorMessage;
FScanner: TDBXSqlScanner;
FDbxConnection: TDBXConnection;
FTransport: TDSServerTransport;
FChannel: TDbxChannel;
FCreateInstanceEventObject: TDSCreateInstanceEventObject;
FDestroyInstanceEventObject: TDSDestroyInstanceEventObject;
FPrepareEventObject: TDSPrepareEventObject;
FConnectEventObject: TDSConnectEventObject;
FErrorEventObject: TDSErrorEventObject;
FServerCon: TDSServerConnection;
end;
TDSServerConnectionPatch = class(TDSServerConnection)
public
destructor Destroy; override;
end;
TDSServerDriverPatch = class(TDSServerDriver)
protected
function CreateConnectionPatch(ConnectionBuilder: TDBXConnectionBuilder): TDBXConnection;
end;
destructor TDSServerConnectionPatch.Destroy;
begin
inherited Destroy;
TDSServerConnectionHandlerAccess(ServerConnectionHandler).FServerCon := nil;
ServerConnectionHandler.Free;
end;
function TDSServerDriverPatch.CreateConnectionPatch(
ConnectionBuilder: TDBXConnectionBuilder): TDBXConnection;
begin
Result := TDSServerConnectionPatch.Create(ConnectionBuilder);
end;
var QC78696: TCodeRedirect;
initialization
QC78696 := TCodeRedirect.Create(#TDSServerDriverPatch.CreateConnection, #TDSServerDriverPatch.CreateConnectionPatch);
finalization
QC78696.Free;
end.
Troubleshoot: Encounter "Invalid command handle" when consume more than one server method at runtime for in-process application
This happens in Delphi 2010 build 14.0.3513.24210. It may have fixed in future release. You may check QC#78698 for latest status.
To replay this problem, you may consume the server method as:
c := TMyServerMethodClient.Create(Q.DBXConnection);
try
ShowMessage(c.EchoString('Hello'));
ShowMessage(IntToStr(c.Sum(100, 200)));
finally
c.Free;
end;
or this:
c := TMyServerMethodClient.Create(Q.DBXConnection);
try
ShowMessage(c.EchoString('Hello'));
ShowMessage(IntToStr(c.Sum(100, 200)));
ShowMessage(c.EchoString('Hello'));
finally
c.Free;
end;
Here is a fix for the problem
unit DSServer.QC78698;
interface
implementation
uses SysUtils, Classes,
DBXCommon, DBXMessageHandlerCommon, DSCommonServer, DSServer,
CodeRedirect;
type
TDSServerCommandAccess = class(TDBXCommand)
private
FConHandler: TDSServerConnectionHandler;
FServerCon: TDSServerConnection;
FRowsAffected: Int64;
FServerParameterList: TDBXParameterList;
end;
TDSServerCommandPatch = class(TDSServerCommand)
private
FCommandHandle: integer;
function Accessor: TDSServerCommandAccess;
private
procedure ExecutePatch;
protected
procedure DerivedClose; override;
function DerivedExecuteQuery: TDBXReader; override;
procedure DerivedExecuteUpdate; override;
function DerivedGetNextReader: TDBXReader; override;
procedure DerivedPrepare; override;
end;
TDSServerConnectionPatch = class(TDSServerConnection)
public
function CreateCommand: TDBXCommand; override;
end;
TDSServerDriverPatch = class(TDSServerDriver)
private
function CreateServerCommandPatch(DbxContext: TDBXContext; Connection:
TDBXConnection; MorphicCommand: TDBXCommand): TDBXCommand;
public
constructor Create(DBXDriverDef: TDBXDriverDef); override;
end;
constructor TDSServerDriverPatch.Create(DBXDriverDef: TDBXDriverDef);
begin
FCommandFactories := TStringList.Create;
rpr;
InitDriverProperties(TDBXProperties.Create);
// '' makes this the default command factory.
//
AddCommandFactory('', CreateServerCommandPatch);
end;
function TDSServerDriverPatch.CreateServerCommandPatch(DbxContext: TDBXContext;
Connection: TDBXConnection; MorphicCommand: TDBXCommand): TDBXCommand;
var
ServerConnection: TDSServerConnection;
begin
ServerConnection := Connection as TDSServerConnection;
Result := TDSServerCommandPatch.Create(DbxContext, ServerConnection, TDSServerHelp.GetServerConnectionHandler(ServerConnection));
end;
function TDSServerCommandPatch.Accessor: TDSServerCommandAccess;
begin
Result := TDSServerCommandAccess(Self);
end;
procedure TDSServerCommandPatch.DerivedClose;
var
Message: TDBXCommandCloseMessage;
begin
Message := Accessor.FServerCon.CommandCloseMessage;
Message.CommandHandle := FCommandHandle;
Message.HandleMessage(Accessor.FConHandler);
end;
function TDSServerCommandPatch.DerivedExecuteQuery: TDBXReader;
var
List: TDBXParameterList;
Parameter: TDBXParameter;
Reader: TDBXReader;
begin
ExecutePatch;
List := Parameters;
if (List <> nil) and (List.Count > 0) then
begin
Parameter := List.Parameter[List.Count - 1];
if Parameter.DataType = TDBXDataTypes.TableType then
begin
Reader := Parameter.Value.GetDBXReader;
Parameter.Value.SetNull;
Exit(Reader);
end;
end;
Result := nil;
end;
procedure TDSServerCommandPatch.DerivedExecuteUpdate;
begin
ExecutePatch;
end;
function TDSServerCommandPatch.DerivedGetNextReader: TDBXReader;
var
Message: TDBXNextResultMessage;
begin
Message := Accessor.FServerCon.NextResultMessage;
Message.CommandHandle := FCommandHandle;
Message.HandleMessage(Accessor.FConHandler);
Result := Message.NextResult;
end;
procedure TDSServerCommandPatch.DerivedPrepare;
begin
inherited;
FCommandHandle := Accessor.FServerCon.PrepareMessage.CommandHandle;
end;
procedure TDSServerCommandPatch.ExecutePatch;
var
Count: Integer;
Ordinal: Integer;
Params: TDBXParameterList;
CommandParams: TDBXParameterList;
Message: TDBXExecuteMessage;
begin
Message := Accessor.FServerCon.ExecuteMessage;
if not IsPrepared then
Prepare;
for ordinal := 0 to Parameters.Count - 1 do
Accessor.FServerParameterList.Parameter[Ordinal].Value.SetValue(Parameters.Parameter[Ordinal].Value);
Message.Command := Text;
Message.CommandType := CommandType;
Message.CommandHandle := FCommandHandle;
Message.Parameters := Parameters;
Message.HandleMessage(Accessor.FConHandler);
Params := Message.Parameters;
CommandParams := Parameters;
if Params <> nil then
begin
Count := Params.Count;
if Count > 0 then
for ordinal := 0 to Count - 1 do
begin
CommandParams.Parameter[Ordinal].Value.SetValue(Params.Parameter[Ordinal].Value);
Params.Parameter[Ordinal].Value.SetNull;
end;
end;
Accessor.FRowsAffected := Message.RowsAffected;
end;
function TDSServerConnectionPatch.CreateCommand: TDBXCommand;
var
Command: TDSServerCommand;
begin
Command := TDSServerCommandPatch.Create(FDbxContext, self, ServerConnectionHandler);
Result := Command;
end;
var QC78698: TCodeRedirect;
initialization
QC78698 := TCodeRedirect.Create(#TDSServerConnection.CreateCommand, #TDSServerConnectionPatch.CreateCommand);
finalization
QC78698.Free;
end.
Reference:
QC#78696: Memory Leak in
TDSServerConnection for in-process
connection
QC#78698: Encounter "Invalid command
handle" when consume more than one
server method at runtime for
in-process application
See DataSnap: In-Process Server Method.

Resources