| sggaunt |
Mar 13th, 2007 12:56 PM |
Update IdTCPSDerver in a DLL
An update of the previouus bits, these were a bit fragmented so this time I am giving you the whole thing!
As an INDY Demo This would seem to do what we want, provided That the altered Indy demo server is run our PIC board can now communicate with the server demo.
But this has to be in a DLL. and that refuses to work.
All that happen is that our hardware 'client' can see a connection being established. but nothing at all is returned from the Delphi application.
Though the calling application can retrieve the settings [bound ports/ machine name etc] from the server component.
Here's the complete code
DLL Main file
:
library Ethernet2;
uses
SysUtils,
Classes,
DataUnit2 in 'DataUnit2.pas' {DataModule2: TDataModule};
{$R *.res}
function Initalise: integer; stdcall;
begin
result := 0;
try
DataModule2 := TDataModule2.Create(nil); // creates the data module
MemRecv := TStringList.Create; // create a string list to hold recived messages
memrecv.Add('Test line');
except
result := 1;
end;
end;
function StopAll: integer; stdcall;
begin
result := 0;
try
Datamodule2.Server.Active := false;
Freeandnil(Memrecv);
except
result := 1;
end;
end;
function ActivateServer: integer; stdcall;
begin
result := 0;
with DataModule2 do
try
Server.Active := True;
except
result := 1;
end;
end;
procedure ChangeSettings(BoundIP: shortstring;
BoundP: integer;
RemoteP: integer); stdcall;
begin
with DataModule2 do
begin
Server.DefaultPort := RemoteP;
Server.Bindings.Items[0].Port := BoundP;
Server.Bindings.Items[0].IP := BoundIp;
end;
end;
// read the first line out of the stringlist and delete it!!
function ReadLine: shortstring; stdcall;
begin
if MemRecv.Count > 0 then
begin
result := MemRecv.Strings[0];
Memrecv.Delete(0);
end
else
result := 'NO DATA';
end;
// read the number of lines stored
function ReadCount: integer; stdcall;
begin
result := MemRecv.count;
end;
function RetrieveSettings(Code: integer): shortstring; stdcall;
begin
with datamodule2 do
case code of
0: result := Server.LocalName;
1: result := inttostr(Server.DefaultPort);
2: result := Server.Version;
else result := 'Illegal Code';
end;
end;
function Minimum(X, Y: Integer): Integer; stdcall;
begin
if X < Y then Minimum := X else Minimum := Y;
end;
function Maximum(X, Y: Integer): Integer; stdcall;
begin
if X > Y then Maximum := X else Maximum := Y;
end;
exports
Initalise, StopAll, ActivateServer, ReadLine,
Minimum, Maximum, RetrieveSettings, ReadCount,
ChangeSettings;
begin
end.
DLL datamodule containg TldTCPServer and IdThreadMGRDefault exactly as on the Demo form.
The only differences are that the data structure definition has been moved into the datamodule code.
A string list has replaced the output memo.
:
unit DataUnit2;
interface
uses
SysUtils, Classes, IdTCPServer, IdBaseComponent, IdComponent,
IdTCPConnection, IdTCPClient, IdThreadMgr, IdThreadMgrDefault;
type
TCommBlock = record // the Communication Block used in both parts (Server+Client)
Command,
MyUserName, // the sender of the message
Msg, // the message itself
ReceiverName: string[25]; // name of receiver
end;
PClient = ^TClient;
TClient = record // Object holding data of client (see events)
DNS : String[20]; { Hostname }
Connected, { Time of connect }
LastAction : TDateTime; { Time of last transaction }
Thread : Pointer; { Pointer to thread }
end;
TDataModule2 = class(TDataModule)
Server: TIdTCPServer;
IdThreadMgrDefault1: TIdThreadMgrDefault;
procedure ServerConnect(AThread: TIdPeerThread);
procedure ServerDisconnect(AThread: TIdPeerThread);
procedure ServerExecute(AThread: TIdPeerThread);
private
{ Private declarations }
public
{ Public declarations }
end;
var
DataModule2: TDataModule2;
Memrecv: Tstringlist;
Clients: TThreadList; // Holds the data of all clients
implementation
{$R *.dfm}
procedure TDataModule2.ServerConnect(AThread: TIdPeerThread);
var NewClient: PClient;
begin
GetMem(NewClient, SizeOf(TClient));
NewClient.DNS := AThread.Connection.LocalName;
NewClient.Connected := Now;
NewClient.LastAction := NewClient.Connected;
NewClient.Thread := AThread;
AThread.Data := TObject(NewClient);
try
Clients.LockList.Add(NewClient);
finally
Clients.UnlockList;
end;
MemRecv.Add(TimeToStr(Time)+' Connection from "' + NewClient.DNS+'"');
AThread.Connection.WriteLn('Connection established');
end;
procedure TDataModule2.ServerDisconnect(AThread: TIdPeerThread);
var ActClient: PClient;
begin
ActClient := PClient(AThread.Data);
MemRecv.Add (TimeToStr(Time)+' Disconnect from "'+ActClient^.DNS+'"');
try
Clients.LockList.Remove(ActClient);
finally
Clients.UnlockList;
end;
FreeMem(ActClient);
AThread.Data := nil;
end;
procedure TDataModule2.ServerExecute(AThread: TIdPeerThread);
var
ActClient, RecClient: PClient;
CommBlock, NewCommBlock: TCommBlock;
RecThread: TIdPeerThread;
i: Integer;
begin
MemRecv.Add(TimeToStr(Time)+' Server execute called ');
if not AThread.Terminated and AThread.Connection.Connected then
begin
AThread.Connection.ReadBuffer (CommBlock, SizeOf (CommBlock));
ActClient := PClient(AThread.Data);
ActClient.LastAction := Now; // update the time of last action
if (CommBlock.Command = 'MESSAGE') or (CommBlock.Command = 'DIALOG') then
begin // 'MESSAGE': A message was send - forward or broadcast it
// 'DIALOG': A dialog-window shall popup on the recipient's screen
// it's the same code for both commands...
if CommBlock.ReceiverName = '' then
begin // no recipient given - broadcast
MemRecv.Add (TimeToStr(Time)+' Broadcasting '+CommBlock.Command+': "'+CommBlock.Msg+'"');
NewCommBlock := CommBlock; // nothing to change ;-))
with Clients.LockList do
try
for i := 0 to Count-1 do // iterate through client-list
begin
RecClient := Items[i]; // get client-object
RecThread := RecClient.Thread; // get client-thread out of it
RecThread.Connection.WriteBuffer(NewCommBlock, SizeOf(NewCommBlock), True); // send the stuff
end;
finally
Clients.UnlockList;
end;
end
else
begin // receiver given - search him and send it to him
NewCommBlock := CommBlock; // again: nothing to change ;-))
MemRecv.Add(TimeToStr(Time)+' Sending '+CommBlock.Command+' to "'+CommBlock.ReceiverName+'": "'+CommBlock.Msg+'"');
with Clients.LockList do
try
for i := 0 to Count-1 do
begin
RecClient:=Items[i];
if RecClient.DNS=CommBlock.ReceiverName then // we don't have a login function so we have to use the DNS (Hostname)
begin
RecThread:=RecClient.Thread;
RecThread.Connection.WriteBuffer(NewCommBlock, SizeOf(NewCommBlock), True);
end;
end;
finally
Clients.UnlockList;
end;
end;
end
else
begin // unknown command given
MemRecv.Add (TimeToStr(Time)+' Unknown command from "' + CommBlock.MyUserName+'": '+CommBlock.Command);
NewCommBlock.Command := 'DIALOG'; // the message should popup on the client's screen
NewCommBlock.MyUserName := '[Server]'; // the server's username
NewCommBlock.Msg := 'I don''t understand your command: "' + CommBlock.Command + '"'; // the message to show
NewCommBlock.ReceiverName := '[return-to-sender]'; // unnecessary
AThread.Connection.WriteBuffer (NewCommBlock, SizeOf (NewCommBlock), true); // and there it goes...
end;
end;
end;
end.
This is the calling application
:
unit test;
interface
uses
{fastmm4,} Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, registry, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
MessageBox: TEdit;
Button2: TButton;
Address: TEdit;
LocalPort: TEdit;
Remoteport: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
SetupBtn: TButton;
Closebtn: TButton;
ReadBtn: TButton;
StopBtn: TButton;
getSetsBtn: TButton;
Label4: TLabel;
OutputBox: TEdit;
SelectSetting: TComboBox;
Label5: TLabel;
Label6: TLabel;
RemCount: TLabel;
IPCheck: TTimer;
ApplyBtn: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure SetupBtnClick(Sender: TObject);
procedure ClosebtnClick(Sender: TObject);
procedure ReadBtnClick(Sender: TObject);
procedure getSetsBtnClick(Sender: TObject);
procedure StopBtnClick(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure IPCheckTimer(Sender: TObject);
procedure ApplyBtnClick(Sender: TObject);
private
{ Private declarations }
procedure ReadRegistry;
procedure WriteRegistry;
public
FIniFile: TReginiFile;
end;
// DLL Function calls
function SayHello: shortstring; stdcall; external 'hellow';
function Maximum(X, Y: Integer): Integer; stdcall; external 'Ethernet2';
function Initalise: integer; stdcall; external 'Ethernet2';
function ActivateServer: integer; stdcall; external 'Ethernet2';
function ReadLine: shortstring; stdcall; external 'Ethernet2';
procedure ChangeSettings(BoundIP: shortstring;
BoundP: integer;
RemoteP: integer); stdcall; external 'Ethernet2';
function RetrieveSettings(Code: integer): shortstring; stdcall; external 'Ethernet2';
function StopAll: integer; stdcall; external 'Ethernet2';
function ReadCount: integer; stdcall; external 'Ethernet2'; // read the number of lines of recived text stored
var
Form1: TForm1;
const
SECTION = 'Intrex\Lantest';
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
if Initalise > 0 then
ShowMessage('Initalisation Error')
else
MessageBox.Text := 'Init OK';
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
MessageBox.Text := inttostr(Maximum(10,20));
end;
procedure TForm1.SetupBtnClick(Sender: TObject);
begin
if ActivateServer() = 0 then
MessageBox.Text := 'Server active';
IpCheck.Enabled := true;
end;
procedure TForm1.ClosebtnClick(Sender: TObject);
begin
ipcheck.Enabled := false;
close
end;
procedure TForm1.ReadBtnClick(Sender: TObject);
begin
MessageBox.Text := ReadLine;
RemCount.Caption := inttostr(ReadCount);
end;
procedure TForm1.getSetsBtnClick(Sender: TObject);
begin
MessageBox.Clear;
MessageBox.Text := RetrieveSettings(SelectSetting.itemindex);
end;
procedure TForm1.StopBtnClick(Sender: TObject);
begin
ipcheck.Enabled := false;
if stopall = 0 then
messagebox.Text := 'Server and Client Stopped'
else
messagebox.Text := 'Error Stopping Server and Client';
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
ReadRegistry;
end;
procedure TForm1.ReadRegistry;
begin
FIniFile := TRegIniFile.Create('Software');
with FIniFile do
begin
Address.Text := ReadString(SECTION, 'Last', '127.0.0.1');
LocalPort.Text := ReadString(SECTION, 'Local Port', '4000');
free;
end;
end;
procedure TForm1.WriteRegistry;
begin
FIniFile := TRegIniFile.Create('Software');
with FIniFile do
begin
WriteString(SECTION, 'Remote', Address.Text);
WriteString(SECTION, 'Local Port', LocalPort.Text);
WriteString(SECTION, 'Remote Port', RemotePort.Text);
free;
end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
WriteRegistry;
end;
procedure TForm1.IPCheckTimer(Sender: TObject);
begin
RemCount.Caption := Inttostr(ReadCount);
end;
procedure TForm1.ApplyBtnClick(Sender: TObject);
begin
ChangeSettings(Address.Text, Strtoint(LocalPort.Text), strtoint(RemotePort.Text));
end;
end.
|
