david
2824855ea7
- Recompilación en Delphi10 de todos los paquetes de RO para generar las DCU's en Lib\D10 - Recompilación en Delphi10 de todos los paquetes de DA para generar las DCU's en Lib\D10 git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@9 b6239004-a887-0f4b-9937-50029ccdca16
1564 lines
47 KiB
ObjectPascal
1564 lines
47 KiB
ObjectPascal
unit MegaDemoClientMain;
|
|
|
|
{ Activate this define if you are using the demo without having Indy installed.
|
|
|
|
Simply click "Ignore" when opening the form to have the Indy components
|
|
remove, set the define and rebuild the demo. }
|
|
|
|
{.$DEFINE NO_INDY}
|
|
{.$DEFINE NO_SYNAPSE}
|
|
{$I RemObjects.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
|
StdCtrls, Spin, ExtCtrls, ComCtrls, SyncObjs, uROClientIntf, TypInfo,
|
|
|
|
{$IFNDEF NO_INDY}
|
|
uROIndyTCPChannel, uROIndyHTTPChannel,
|
|
{$ENDIF NO_INDY}
|
|
{$IFNDEF NO_SYNAPSE}
|
|
uROSynapseHttpChannel,
|
|
{$ENDIF}
|
|
uROClient, uROBINMessage, uROWinMessageChannel, uROSOAPMessage,
|
|
uROWinInetHttpChannel, uROXMLIntf, MegaDemoLibrary_Intf, uROTypes,
|
|
uRORemoteService, uROPoweredByRemObjectsButton, uROXmlRpcMessage,
|
|
ImgList, Buttons, uRODynamicRequest, uROPostMessage, CheckLst;
|
|
|
|
const
|
|
msgWarningPorts =
|
|
'Issuing many requests in a short period of time can cause the client PC to run out of ip-port combinations.' + sLineBreak +
|
|
'Once an ip-port combination has been used, it takes some time (1 to 4 min on Windows) before that combination can be re-used' + sLineBreak + '' + sLineBreak +
|
|
'Run netstat from command prompt to see how many connections are in TIME_WAIT state.' + sLineBreak + '' + sLineBreak +
|
|
'If you have long loops (i.e 50 cycles or 5 threads running 10) allow your PC to restore some ports by not' + sLineBreak +
|
|
'doing anything for a minute or so once the test has completed.' + sLineBreak + '' + sLineBreak +
|
|
'Do you want to continue?';
|
|
|
|
type
|
|
TArrayType = (atInteger, atString, atTPerson);
|
|
|
|
TStressMethod = function(aService: IMegaDemoService): integer of object;
|
|
|
|
TMegaDemoClientMainForm = class(TForm)
|
|
IndyHttpChannel: TROIndyHTTPChannel;
|
|
BINMessage: TROBINMessage;
|
|
SOAPMessage: TROSOAPMessage;
|
|
IndyTcpChannel: TROIndyTCPChannel;
|
|
WinMessageChannel: TROWinMessageChannel;
|
|
PageControl1: TPageControl;
|
|
tsSoap: TTabSheet;
|
|
tsLog: TTabSheet;
|
|
Memo: TMemo;
|
|
Memo1: TMemo;
|
|
Memo2: TMemo;
|
|
Splitter1: TSplitter;
|
|
WininetHttpChannel: TROWinInetHTTPChannel;
|
|
RemoteService: TRORemoteService;
|
|
Panel3: TPanel;
|
|
PostMessage: TROPostMessage;
|
|
Panel4: TPanel;
|
|
clbTests: TCheckListBox;
|
|
pagecontrol2: TPageControl;
|
|
tsStress: TTabSheet;
|
|
tsSum: TTabSheet;
|
|
tsEchoPerson: TTabSheet;
|
|
tsRaiseError: TTabSheet;
|
|
seA: TSpinEdit;
|
|
seB: TSpinEdit;
|
|
Label4: TLabel;
|
|
seAge: TSpinEdit;
|
|
cbSex: TComboBox;
|
|
eLastName: TEdit;
|
|
eFirstName: TEdit;
|
|
Label3: TLabel;
|
|
Label2: TLabel;
|
|
cbCustomException: TCheckBox;
|
|
Label5: TLabel;
|
|
tsTestArrays: TTabSheet;
|
|
tsEchoBinary: TTabSheet;
|
|
tsGetServerTime: TTabSheet;
|
|
tsCustomClass: TTabSheet;
|
|
Label6: TLabel;
|
|
seArrayCount: TSpinEdit;
|
|
rbInteger: TRadioButton;
|
|
rbString: TRadioButton;
|
|
rbTPerson: TRadioButton;
|
|
seBinSize: TSpinEdit;
|
|
Label7: TLabel;
|
|
rbStream: TRadioButton;
|
|
rbXML: TRadioButton;
|
|
Panel5: TPanel;
|
|
Panel1: TPanel;
|
|
GroupBox6: TGroupBox;
|
|
Label1: TLabel;
|
|
Label8: TLabel;
|
|
Label9: TLabel;
|
|
Label10: TLabel;
|
|
Label12: TLabel;
|
|
Bevel1: TBevel;
|
|
Bevel2: TBevel;
|
|
Label13: TLabel;
|
|
rbWinMessage: TRadioButton;
|
|
rbTcpChannel: TRadioButton;
|
|
rbHttpChannel: TRadioButton;
|
|
eServerID: TEdit;
|
|
cbHTTPURL: TComboBox;
|
|
cbTCPIP: TComboBox;
|
|
cbTCPPort: TComboBox;
|
|
Panel2: TPanel;
|
|
rbIndyHttp: TRadioButton;
|
|
rbWinInetHttp: TRadioButton;
|
|
cbKeepConnection: TCheckBox;
|
|
Panel6: TPanel;
|
|
RbIndyTcp: TRadioButton;
|
|
cbDisableNagle: TCheckBox;
|
|
GroupBox5: TGroupBox;
|
|
rbBinary: TRadioButton;
|
|
rbSOAP: TRadioButton;
|
|
cbUseCompression: TCheckBox;
|
|
rbPost: TRadioButton;
|
|
cbEncrypt: TCheckBox;
|
|
RoPoweredByRemObjectsButton1: TROPoweredByRemObjectsButton;
|
|
cbEnableLog: TCheckBox;
|
|
cbVerbose: TCheckBox;
|
|
cbWriteTestInfo: TCheckBox;
|
|
Label11: TLabel;
|
|
Label16: TLabel;
|
|
Label17: TLabel;
|
|
Label18: TLabel;
|
|
Label19: TLabel;
|
|
Label20: TLabel;
|
|
Label21: TLabel;
|
|
Label22: TLabel;
|
|
Label23: TLabel;
|
|
Label24: TLabel;
|
|
RunTestOnceButton: TButton;
|
|
RunTestButton: TButton;
|
|
seRepetitions: TSpinEdit;
|
|
Label15: TLabel;
|
|
seThreads: TSpinEdit;
|
|
Label14: TLabel;
|
|
pStress: TPanel;
|
|
pSum: TPanel;
|
|
pTestArrays: TPanel;
|
|
pEchoBinary: TPanel;
|
|
pGetServerTime: TPanel;
|
|
pCustomClass: TPanel;
|
|
pRaiseError: TPanel;
|
|
pPage: TPanel;
|
|
pEchoPerson: TPanel;
|
|
rbSynapseHttp: TRadioButton;
|
|
rbXmlRpc: TRadioButton;
|
|
XmlRpcMessage: TROXmlRpcMessage;
|
|
cbAutoDetect: TCheckBox;
|
|
procedure FormCreate(Sender: TObject);
|
|
procedure FormDestroy(Sender: TObject);
|
|
procedure bTestEchoBinaryClick(Sender: TObject);
|
|
procedure Image1Click(Sender: TObject);
|
|
procedure cbEncryptClick(Sender: TObject);
|
|
procedure rbBinaryClick(Sender: TObject);
|
|
procedure rbSOAPClick(Sender: TObject);
|
|
procedure cbDisableNagleClick(Sender: TObject);
|
|
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
|
|
procedure bbStressCustomClassClick(Sender: TObject);
|
|
procedure rbPostClick(Sender: TObject);
|
|
procedure cbHTTPURLChange(Sender: TObject);
|
|
procedure SOAPMessageWriteToStream(aStream: TStream);
|
|
procedure SOAPMessageEnvelopeComplete(Sender: TROSOAPMessage);
|
|
procedure SOAPMessageReadFromStream(aStream: TStream);
|
|
procedure BINMessageFinalizeMessage(Sender: TROMessage);
|
|
procedure BINMessageReadMessageParameter(Sender: TROMessage;
|
|
const aName: string; aTypeInfo: PTypeInfo; const DataRef: Pointer;
|
|
Attributes: TParamAttributes);
|
|
procedure BINMessageWriteMessageParameter(Sender: TROMessage;
|
|
const aName: string; aTypeInfo: PTypeInfo; const DataRef: Pointer;
|
|
Attributes: TParamAttributes);
|
|
procedure BINMessageInitializeMessage(Sender: TROMessage;
|
|
const aTransport: IROTransport; const anInterfaceName,
|
|
aMessageName: string);
|
|
procedure clbTestsClick(Sender: TObject);
|
|
procedure RunTestOnceButtonClick(Sender: TObject);
|
|
procedure RunTestButtonClick(Sender: TObject);
|
|
procedure FormShow(Sender: TObject);
|
|
procedure clbTestsClickCheck(Sender: TObject);
|
|
procedure rbHttpChannelClick(Sender: TObject);
|
|
procedure FormDeactivate(Sender: TObject);
|
|
procedure rbIndyHttpClick(Sender: TObject);
|
|
procedure rbXmlRpcClick(Sender: TObject);
|
|
procedure cbAutoDetectClick(Sender: TObject);
|
|
private
|
|
{$IFNDEF NO_SYNAPSE}
|
|
ROSynapseHttpchannel: TROSynapseHTTPChannel;
|
|
{$ENDIF}
|
|
fCritical: TCriticalSection;
|
|
fThreads: TList;
|
|
fTerminateTest: boolean;
|
|
fMessage: TROMessage;
|
|
fChannel: TROTransportChannel;
|
|
fMegaTestStart: cardinal;
|
|
fLogEnabledStatus: boolean;
|
|
|
|
function CreateService: IMegaDemoService;
|
|
procedure ChangeUrl(iTo: string);
|
|
procedure Log(const aMessage: string; Force: boolean = FALSE);
|
|
|
|
procedure NotifyThreadTermination(aThread: TThread);
|
|
function GetMegaTestRunning: boolean;
|
|
|
|
// Methods to invoke the remote service. These are also used by the stress threads later.
|
|
// They return the time it took to execute
|
|
function InvokeCustomClass(const aService: IMegaDemoService; UseBinaryStream: boolean): integer;
|
|
{} function InvokeEchoBinary(const aService: IMegaDemoService; aSize: integer): integer;
|
|
{} function InvokeEchoPerson(const aService: IMegaDemoService; const aFirstName, aLastName: string; anAge: integer; aSex: TSex): integer;
|
|
{} function InvokeRaiseError(const aService: IMegaDemoService): integer;
|
|
{} function InvokeSum(const aService: IMegaDemoService; A, B: integer): integer;
|
|
{} function InvokeTestArray(const aService: IMegaDemoService; anArrayType: TArrayType; aCount: integer): integer;
|
|
{} function InvokeGetServerTime(const aService: IMegaDemoService): integer;
|
|
|
|
// Logs
|
|
procedure WriteSequentialStressEnd(TotalTime, Errors: integer);
|
|
|
|
procedure WriteSequentialStressStart(TestName: string; const ExtraInfo: string = '');
|
|
|
|
procedure WriteTestInfo(ARunOnce: Boolean);
|
|
function GetRequestsPerSecond(TotalTimeMS: integer): double;
|
|
procedure Check_ListBoxClick(isAllDemo: Boolean);
|
|
|
|
procedure Stress(AMethod: TStressMethod);
|
|
function RunSum(aService: IMegaDemoService): integer;
|
|
function RunEchoPerson(aService: IMegaDemoService): integer;
|
|
function RunRaiseError(aService: IMegaDemoService): integer;
|
|
function RunTestArrays(aService: IMegaDemoService): integer;
|
|
function int_RunTestArrays(aService: IMegaDemoService; anArrayType: TArrayType): integer;
|
|
function RunEchoBinary(aService: IMegaDemoService): integer;
|
|
function RunServerTime(aService: IMegaDemoService): integer;
|
|
function RunCustomClass(aService: IMegaDemoService): integer;
|
|
|
|
procedure RunAllDemo;
|
|
procedure StopAllDemo;
|
|
|
|
procedure LoadFromIni;
|
|
procedure SaveToIni;
|
|
|
|
public
|
|
constructor Create(aOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
|
|
property UserChannel: TROTransportChannel read fChannel;
|
|
property UserMessage: TROMessage read fMessage;
|
|
property MegaTestRunning: boolean read GetMegaTestRunning;
|
|
end;
|
|
|
|
var
|
|
MegaDemoClientMainForm: TMegaDemoClientMainForm;
|
|
|
|
implementation
|
|
|
|
uses INIFiles, MegaDemoCustomClass, uROXMLSerializer, uROStreamSerializer,
|
|
ShellAPI, uROEncryption, ActiveX;
|
|
|
|
{$R *.DFM}
|
|
|
|
type
|
|
{ TStressThread }
|
|
TStressThread = class(TThread)
|
|
private
|
|
fMessage: TROMessage;
|
|
fChannel: TROTransportChannel;
|
|
fErrors,
|
|
fSumTime,
|
|
fEchoPersonTime,
|
|
fRaiseErrorTime,
|
|
fArrayTime,
|
|
fEchoBinaryTime,
|
|
fGetServerTimeTime,
|
|
fCustomClassTime,
|
|
fTotalTime: integer;
|
|
Fidx: integer;
|
|
procedure BeforeDestroyThread;
|
|
procedure Run;
|
|
public
|
|
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
|
|
procedure Execute; override;
|
|
|
|
property Errors: integer read fErrors;
|
|
property EchoPersonTime: integer read fEchoPersonTime;
|
|
property RaiseErrorTime: integer read fRaiseErrorTime;
|
|
property ArrayTime: integer read fArrayTime;
|
|
property EchoBinaryTime: integer read fEchoBinaryTime;
|
|
property GetServerTimeTime: integer read fGetServerTimeTime;
|
|
property CustomClassTime: integer read fCustomClassTime;
|
|
property TotalTime: integer read fTotalTime;
|
|
property idx: integer read Fidx write Fidx;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.FormCreate(Sender: TObject);
|
|
var
|
|
sx: TSex;
|
|
begin
|
|
Caption := Application.Title;
|
|
|
|
{$IFDEF NO_INDY}
|
|
rbIndyHttp.Enabled := false;
|
|
rbIndyTcp.Enabled := false;
|
|
{$ENDIF NO_INDY}
|
|
{$IFDEF NO_SYNAPSE}
|
|
rbSynapseHttp.Enabled := false;
|
|
{$ELSE}
|
|
ROSynapseHttpchannel := TROSynapseHTTPChannel.Create(self);
|
|
ROSynapseHttpchannel.Encryption.EncryptionSendKey := IndyHttpChannel.Encryption.EncryptionSendKey;
|
|
ROSynapseHttpchannel.Encryption.EncryptionRecvKey := IndyHttpChannel.Encryption.EncryptionRecvKey;
|
|
{$ENDIF}
|
|
LoadFromIni;
|
|
|
|
for sx := Low(TSex) to High(TSex) do
|
|
cbSex.Items.Add(GetEnumName(TypeInfo(TSex), Ord(sx)));
|
|
cbSex.ItemIndex := 0;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.FormDestroy(Sender: TObject);
|
|
begin
|
|
SaveToIni;
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.CreateService: IMegaDemoService;
|
|
begin
|
|
// Adds the entry if new
|
|
with cbTCPIP do
|
|
if (Items.IndexOf(Text) < 0) and (Text <> '') then
|
|
Items.Add(Text);
|
|
|
|
with cbHTTPURL do
|
|
if (Items.IndexOf(Text) < 0) and (Text <> '') then
|
|
Items.Add(Text);
|
|
|
|
with cbTCPPort do
|
|
if (Items.IndexOf(Text) < 0) and (Text <> '') then
|
|
Items.Add(Text);
|
|
|
|
{ Set up BIN message }
|
|
BINMessage.UseCompression := cbUseCompression.Checked;
|
|
|
|
{ Set up Http Channels }
|
|
{$IFNDEF NO_INDY}
|
|
IndyHTTPChannel.TargetURL := cbHTTPURL.Text;
|
|
IndyHTTPChannel.KeepAlive := cbKeepConnection.Checked;
|
|
{$ENDIF NO_INDY}
|
|
{$IFNDEF NO_SYNAPSE}
|
|
ROSYnapseHttpchannel.TargetURL := cbHTTPURL.Text;
|
|
ROSYnapseHttpchannel.KeepAlive := cbKeepConnection.Checked;
|
|
{$ENDIF NO_SYNAPSE}
|
|
WininetHttpChannel.TargetURL := cbHTTPURL.Text;
|
|
WininetHttpChannel.KeepConnection := cbKeepConnection.Checked;
|
|
|
|
{ Set up Tcp Channels }
|
|
{$IFNDEF NO_INDY}
|
|
{$IFDEF RemObjects_INDY10}
|
|
TIdIndy10HackClient(IndyTCPChannel.IndyClient).Host := cbTCPIP.Text;
|
|
TIdIndy10HackClient(IndyTCPChannel.IndyClient).Port := StrToInt(cbTCPPort.Text);
|
|
{$ELSE RemObjects_INDY10}
|
|
IndyTCPChannel.IndyClient.Host := cbTCPIP.Text;
|
|
IndyTCPChannel.IndyClient.Port := StrToInt(cbTCPPort.Text);
|
|
{$ENDIF RemObjects_INDY10}
|
|
{$ENDIF NO_INDY}
|
|
|
|
{ Set up WM Channel }
|
|
WinMessageChannel.ServerID := LibraryUID;
|
|
|
|
{ Select message class based on radio button selection }
|
|
if rbBinary.Checked then
|
|
fMessage := BINMessage
|
|
else if rbPost.Checked then
|
|
fMessage := PostMessage
|
|
else if rbXMLRpc.Checked then
|
|
fMessage := XmlRpcMessage
|
|
else
|
|
fMessage := SOAPMessage;
|
|
|
|
{ Select channel class based on radio button selection }
|
|
if rbWinMessage.Checked then begin
|
|
fChannel := WinMessageChannel
|
|
end
|
|
else if rbTCPChannel.Checked then begin
|
|
|
|
{$IFNDEF NO_INDY}
|
|
fChannel := IndyTCPChannel;
|
|
{$ENDIF NO_INDY}
|
|
|
|
end
|
|
else begin
|
|
|
|
{$IFNDEF NO_INDY}
|
|
if rbIndyHttp.Checked then
|
|
fChannel := IndyHttpChannel
|
|
else
|
|
{$ENDIF NO_INDY}
|
|
{$IFNDEF NO_INDY}
|
|
if rbSynapseHttp.Checked then
|
|
fChannel := ROSynapseHttpchannel
|
|
else
|
|
{$ENDIF NO_INDY}
|
|
fChannel := WininetHttpChannel;
|
|
|
|
end;
|
|
|
|
// Sets up the main components
|
|
RemoteService.Channel := fChannel;
|
|
RemoteService.Message := fMessage;
|
|
|
|
result := RemoteService as IMegaDemoService;
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.InvokeSum(const aService: IMegaDemoService; A, B: integer):
|
|
integer;
|
|
var
|
|
res: integer;
|
|
start: cardinal;
|
|
begin
|
|
start := GetTickCount;
|
|
res := aService.Sum(seA.Value, seB.Value);
|
|
result := GetTickCount - start;
|
|
Log('Sum');
|
|
Log('---');
|
|
Log(Format('outgoing:'#9'A=%d B=%d', [seA.Value, seB.Value]));
|
|
Log(Format('incoming:'#9'Result=%d', [res]));
|
|
Log('');
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.InvokeEchoPerson(const aService: IMegaDemoService;
|
|
const aFirstName, aLastName: string; anAge: integer; aSex: TSex): integer;
|
|
var
|
|
outgoing, incoming: TPerson;
|
|
start: cardinal;
|
|
begin
|
|
outgoing := TPerson.Create;
|
|
outgoing.FirstName := eFirstName.Text;
|
|
outgoing.LastName := eLastName.Text;
|
|
outgoing.Age := seAge.Value;
|
|
outgoing.Sex := TSex(cbSex.ItemIndex);
|
|
|
|
try
|
|
start := GetTickCount;
|
|
aService.EchoPerson(outgoing, incoming);
|
|
result := GetTickCount - start;
|
|
|
|
Log('EchoPerson');
|
|
Log('----------');
|
|
with outgoing do
|
|
Log(Format('%s:'#9'%s, %s, %s, %s', ['outgoing', FirstName, LastName, IntToStr(Age), GetEnumName(TypeInfo(TSex), Ord(Sex))]));
|
|
with incoming do
|
|
Log(Format('%s:'#9'%s, %s, %s, %s', ['incoming', FirstName, LastName, IntToStr(Age), GetEnumName(TypeInfo(TSex), Ord(Sex))]));
|
|
|
|
Log('');
|
|
|
|
finally
|
|
incoming.Free;
|
|
outgoing.Free;
|
|
end;
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.InvokeRaiseError(const aService: IMegaDemoService): integer;
|
|
var
|
|
start: cardinal;
|
|
begin
|
|
Result := 0;
|
|
start := GetTickCount;
|
|
Log('RaiseError');
|
|
Log('----------');
|
|
try
|
|
try
|
|
if not cbCustomException.Checked then
|
|
aService.RaiseError()
|
|
else
|
|
aService.RaiseTestException;
|
|
finally
|
|
result := GetTickCount - start;
|
|
end;
|
|
except
|
|
on E: ETestException do
|
|
if rbXmlRpc.Checked then
|
|
Log(Format(
|
|
'ETestException' + sLineBreak +
|
|
'Message:'#9'%s',
|
|
[E.Message]), true)
|
|
else
|
|
Log(Format(
|
|
'ETestException' + sLineBreak +
|
|
'Message:'#9'%s' + sLineBreak +
|
|
'ErrorCode:'#9'%d' + sLineBreak +
|
|
'AdditionalInfo:'#9'%s',
|
|
[E.Message, E.ErrorCode, E.AdditionalInfo]), true);
|
|
on E: Exception do
|
|
Log(
|
|
'Generic exception:'#9 + E.ClassName + sLineBreak +
|
|
'Message:'#9#9 + E.Message, true);
|
|
end;
|
|
Log('');
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.InvokeTestArray(const aService: IMegaDemoService;
|
|
anArrayType: TArrayType; aCount: integer): integer;
|
|
var
|
|
i: integer;
|
|
iarr, iarr2: TIntegerArray;
|
|
sarr, sarr2: TStringArray;
|
|
parr, parr2: TPersonArray;
|
|
s, s1: string;
|
|
err: boolean;
|
|
start: cardinal;
|
|
begin
|
|
Result := 0;
|
|
s := '';
|
|
err := FALSE;
|
|
|
|
iarr := nil;
|
|
iarr2 := nil;
|
|
sarr := nil;
|
|
sarr2 := nil;
|
|
parr := nil;
|
|
parr2 := nil;
|
|
|
|
try
|
|
case anArrayType of
|
|
atInteger: try
|
|
s1 := rbInteger.Caption;
|
|
Randomize;
|
|
iarr := TIntegerArray.Create;
|
|
iarr.Resize(seArrayCount.Value);
|
|
for i := 0 to (seArrayCount.Value - 1) do
|
|
iarr[i] := Random(100);
|
|
|
|
start := GetTickCount;
|
|
iarr2 := aService.TestIntegerArray(iarr);
|
|
result := GetTickCount - start;
|
|
|
|
for i := 0 to (seArrayCount.Value - 1) do begin
|
|
s := s + Format('%d:'#9'%d - %d', [i, iarr[i], iarr2[i]]) + sLineBreak;
|
|
if (iarr2[i] <> iarr[i]) then begin
|
|
err := TRUE;
|
|
Exit;
|
|
end;
|
|
end;
|
|
finally
|
|
iarr.Free;
|
|
iarr2.Free;
|
|
end;
|
|
|
|
atString: try
|
|
s1 := rbString.Caption;
|
|
Randomize;
|
|
sarr := TStringArray.Create;
|
|
sarr.Resize(seArrayCount.Value);
|
|
|
|
for i := 0 to (seArrayCount.Value - 1) do begin
|
|
sarr[i] := 'Value is ' + IntToStr(Random(1000) + 1000);
|
|
end;
|
|
|
|
start := GetTickCount;
|
|
sarr2 := aService.TestStringArray(sarr);
|
|
result := GetTickCount - start;
|
|
|
|
for i := 0 to (seArrayCount.Value - 1) do begin
|
|
s := s + Format('%d:'#9'"%s" - "%s"', [i, sarr[i], sarr2[i]]) + sLineBreak;
|
|
if (sarr2[i] <> sarr[i]) then begin
|
|
err := TRUE;
|
|
Exit;
|
|
end;
|
|
end;
|
|
finally
|
|
sarr.Free;
|
|
sarr2.Free;
|
|
end;
|
|
|
|
atTPerson: try
|
|
s1 := rbTPerson.Caption;
|
|
parr := TPersonArray.Create;
|
|
parr.Resize(seArrayCount.Value);
|
|
|
|
for i := 0 to (seArrayCount.Value - 1) do begin
|
|
parr[i] := TPerson.Create;
|
|
with parr[i] do begin
|
|
FirstName := eFirstName.Text;
|
|
LastName := eLastName.Text;
|
|
Age := seAge.Value;
|
|
Sex := TSex(cbSex.ItemIndex);
|
|
end;
|
|
end;
|
|
|
|
start := GetTickCount;
|
|
parr2 := aService.TestPersonArray(parr);
|
|
result := GetTickCount - start;
|
|
|
|
for i := 0 to (seArrayCount.Value - 1) do begin
|
|
s := s + Format('%d:'#9'%s %s %d %d - %s %s %d %d', [
|
|
i,
|
|
parr[i].FirstName, parr[i].LastName, parr[i].Age,
|
|
Ord(parr[i].Sex),
|
|
parr2[i].FirstName, parr2[i].LastName, parr2[i].Age,
|
|
Ord(parr2[i].Sex)]) + sLineBreak;
|
|
|
|
if (parr2[i].FirstName <> parr[i].FirstName) or
|
|
(parr2[i].LastName <> parr[i].LastName) or
|
|
(parr2[i].Age <> parr[i].Age) or
|
|
(parr2[i].Sex <> parr[i].Sex) then begin
|
|
err := TRUE;
|
|
Exit;
|
|
end;
|
|
end;
|
|
finally
|
|
parr.Free;
|
|
parr2.Free;
|
|
end;
|
|
end;
|
|
finally
|
|
if err then
|
|
s := 'Arrays are DIFFERENT!' + sLineBreak + s
|
|
else
|
|
s := sLineBreak + 'Arrays equal!' + sLineBreak + s;
|
|
Log('TestArray');
|
|
Log('---------');
|
|
Log('Mode:'#9 + s1);
|
|
Log(s);
|
|
end;
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.InvokeEchoBinary(const aService: IMegaDemoService; aSize:
|
|
integer): integer;
|
|
var
|
|
binin, binout: Binary;
|
|
i: integer;
|
|
b: byte;
|
|
start: cardinal;
|
|
begin
|
|
Randomize;
|
|
binin := Binary.Create;
|
|
binout := nil;
|
|
|
|
try
|
|
binin.SetSize(seBinSize.Value);
|
|
binin.Position := 0;
|
|
for i := 1 to seBinSize.Value do begin
|
|
b := Random($FF);
|
|
binin.Write(b, SizeOf(b));
|
|
end;
|
|
|
|
binin.Position := 0;
|
|
|
|
start := GetTickCount;
|
|
aService.EchoBinary(binin, binout);
|
|
result := GetTickCount - start;
|
|
|
|
Log('EchoBinary');
|
|
Log('-------------');
|
|
|
|
Log('outgoing:'#9 + IntToStr(binin.Size) + ' bytes');
|
|
Log('incoming:'#9 + IntToStr(binout.Size) + ' bytes');
|
|
|
|
if (binin.Size = binout.Size) then begin
|
|
if CompareMem(binin.Memory, binout.Memory, binout.Size) then
|
|
Log('Data is equivalent!')
|
|
else
|
|
Log('Data is different!');
|
|
end
|
|
else begin
|
|
Log('Different size!');
|
|
end;
|
|
Log('');
|
|
finally
|
|
binin.Free;
|
|
binout.Free;
|
|
end;
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.InvokeCustomClass(const aService: IMegaDemoService;
|
|
UseBinaryStream: boolean): integer;
|
|
var
|
|
cls: TCustomClass;
|
|
stream: Binary;
|
|
xml: string;
|
|
start: cardinal;
|
|
begin
|
|
stream := nil;
|
|
cls := nil;
|
|
try
|
|
if not UseBinaryStream then begin
|
|
start := GetTickCount;
|
|
xml := aService.CustomObjectAsString;
|
|
result := GetTickCount - start;
|
|
cls := XMLToObject(xml) as TCustomClass;
|
|
end
|
|
else begin
|
|
start := GetTickCount;
|
|
stream := aService.CustomObjectAsStream;
|
|
result := GetTickCount - start;
|
|
cls := StreamToObject(stream) as TCustomClass;
|
|
end;
|
|
Log('CustomClass');
|
|
Log('-----------');
|
|
Log('incoming:');
|
|
// incoming data
|
|
with cls do begin
|
|
Log('Random integer:'#9#9 + intToStr(RandomInt));
|
|
Log('Random double:'#9#9 + FloatToStr(RandomDouble));
|
|
Log('Random string:'#9#9 + RandomStr);
|
|
Log('Random widestring:'#9 + RandomWideStr);
|
|
end;
|
|
finally
|
|
stream.Free;
|
|
cls.Free;
|
|
end;
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.InvokeGetServerTime(const aService: IMegaDemoService): integer;
|
|
var
|
|
start: cardinal;
|
|
restime: TDateTime;
|
|
begin
|
|
start := GetTickCount;
|
|
restime := aService.GetServerTime;
|
|
result := GetTickCount - start;
|
|
Log('GetServerTime');
|
|
Log('------------------');
|
|
Log('incoming:'#9 + DateTimeToStr(restime));
|
|
Log('');
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.bTestEchoBinaryClick(Sender: TObject);
|
|
begin
|
|
InvokeEchoBinary(CreateService, seBinSize.Value);
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.Image1Click(Sender: TObject);
|
|
begin
|
|
ShellExecute(Handle, 'open', 'http://www.remobjects.com', nil, nil, SW_SHOWNORMAL);
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.cbEncryptClick(Sender: TObject);
|
|
var
|
|
lEncryption: TROEncryptionMethod;
|
|
begin
|
|
if cbEncrypt.Checked then
|
|
lEncryption := tetDES
|
|
else
|
|
lEncryption := tetNone;
|
|
|
|
{$IFNDEF NO_INDY}
|
|
IndyHttpChannel.Encryption.EncryptionMethod := lEncryption;
|
|
IndyTcpChannel.Encryption.EncryptionMethod := lEncryption;
|
|
{$ENDIF NO_INDY}
|
|
{$IFNDEF NO_SYNAPSE}
|
|
ROSynapseHttpchannel.Encryption.EncryptionMethod := lEncryption;
|
|
{$ENDIF}
|
|
|
|
WinMessageChannel.Encryption.EncryptionMethod := lEncryption;
|
|
WininetHttpChannel.Encryption.EncryptionMethod := lEncryption;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.ChangeUrl(iTo: string);
|
|
begin
|
|
{ lame, but works }
|
|
if cbAutoDetect.Checked then iTo:='';
|
|
cbHTTPURL.Text := StringReplace(cbHTTPURL.Text, '/bin', '/' + iTo, [rfReplaceAll, rfIgnoreCase]);
|
|
cbHTTPURL.Text := StringReplace(cbHTTPURL.Text, '/soap', '/' + iTo, [rfReplaceAll, rfIgnoreCase]);
|
|
cbHTTPURL.Text := StringReplace(cbHTTPURL.Text, '/post', '/' + iTo, [rfReplaceAll, rfIgnoreCase]);
|
|
cbHTTPURL.Text := StringReplace(cbHTTPURL.Text, '/xmlrpc', '/' + iTo, [rfReplaceAll, rfIgnoreCase]);
|
|
if not cbAutoDetect.Checked and (Pos(iTo, cbHTTPURL.Text) = 0) then
|
|
cbHTTPURL.Text:=cbHTTPURL.Text+iTo;
|
|
|
|
cbUseCompression.Enabled := rbBinary.Checked;
|
|
cbVerbose.Enabled := rbBinary.Checked;
|
|
|
|
tsSoap.TabVisible := rbSOAP.Checked;
|
|
if not tsSoap.TabVisible then tsLog.PageControl.ActivePage := tsLog;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.rbBinaryClick(Sender: TObject);
|
|
begin
|
|
ChangeUrl('bin');
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.rbSOAPClick(Sender: TObject);
|
|
begin
|
|
ChangeUrl('soap');
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.rbPostClick(Sender: TObject);
|
|
begin
|
|
ChangeUrl('post');
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.cbDisableNagleClick(Sender: TObject);
|
|
begin
|
|
IndyTCPChannel.DisableNagle := cbDisableNagle.Checked;
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.GetRequestsPerSecond(TotalTimeMS: integer): double;
|
|
begin
|
|
if TotalTimeMS > 0 then
|
|
result := (seRepetitions.Value) / (TotalTimeMS / 1000)
|
|
else
|
|
result := seRepetitions.Value;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.NotifyThreadTermination(aThread: TThread);
|
|
var
|
|
totaltimemega, idx: integer;
|
|
overallrsec: double;
|
|
begin
|
|
fCritical.Enter;
|
|
try
|
|
idx := TStressThread(aThread).idx;
|
|
|
|
Log(Format('Thread %d has terminated. %dms. %f Req/Sec. %d Errors', [idx, TStressThread(aThread).TotalTime, GetRequestsPerSecond(TStressThread(aThread).TotalTime), TStressThread(aThread).Errors]), TRUE);
|
|
|
|
fThreads.Remove(aThread);
|
|
|
|
if fThreads.Count = 0 then begin
|
|
Screen.Cursor := crDefault;
|
|
|
|
totaltimemega := GetTickCount - fMegaTestStart;
|
|
overallrsec := (seThreads.Value * seRepetitions.Value) / (totaltimemega / 1000);
|
|
|
|
Log(Format('The test was completed in %dms. %f Total req/second', [totaltimemega, overallrsec]), TRUE);
|
|
Caption := Application.Title;
|
|
end
|
|
else begin
|
|
Caption := Application.Title + Format(' (%d threads running)', [fThreads.Count]);
|
|
end;
|
|
|
|
Application.ProcessMessages;
|
|
finally
|
|
fCritical.Leave;
|
|
end;
|
|
end;
|
|
|
|
constructor TMegaDemoClientMainForm.Create(aOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
fCritical := TCriticalSection.Create;
|
|
fThreads := TList.Create;
|
|
end;
|
|
|
|
destructor TMegaDemoClientMainForm.Destroy;
|
|
begin
|
|
fCritical.Free;
|
|
fThreads.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.FormCloseQuery(Sender: TObject;
|
|
var CanClose: Boolean);
|
|
begin
|
|
CanClose := not MegaTestRunning;
|
|
|
|
if not CanClose then begin
|
|
if (MessageDlg('Do you want to stop the mega test?', mtWarning, [mbYes, mbNo], 0) = mrYes) then
|
|
StopAllDemo
|
|
else
|
|
Exit;
|
|
|
|
while MegaTestRunning do
|
|
Application.ProcessMessages;
|
|
|
|
CanClose := TRUE;
|
|
end;
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.GetMegaTestRunning: boolean;
|
|
begin
|
|
result := fThreads.Count > 0
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.WriteTestInfo(ARunOnce: Boolean);
|
|
begin
|
|
if not cbWriteTestInfo.Checked then Exit;
|
|
|
|
Log('', TRUE);
|
|
Log('------------------ Test Parameters ------------------', TRUE);
|
|
Log('Channel:'#9 + UserChannel.ClassName, True);
|
|
if rbHttpChannel.Checked then begin
|
|
Log('URL:'#9#9 + cbHTTPURL.Text, True);
|
|
Log('KeepConnection:'#9 + BoolToStr(cbKeepConnection.Checked, TRUE), True);
|
|
end
|
|
else if rbTcpChannel.Checked then begin
|
|
Log('IP, port:'#9 + cbTCPIP.Text + ':' + cbTCPPort.Text, True);
|
|
LOG('DisableNagle:'#9 + BoolToStr(cbDisableNagle.Checked, TRUE), True);
|
|
end
|
|
else if rbWinMessage.Checked then begin
|
|
Log('Server ID:'#9 + eServerID.Text, True);
|
|
end;
|
|
|
|
Log('Message:'#9 + UserMessage.ClassName, True);
|
|
Log('Encrypt:'#9 + BoolToStr(cbEncrypt.Checked, TRUE), True);
|
|
if rbBinary.Checked then begin
|
|
Log('Compression:'#9 + BoolToStr(cbUseCompression.Checked, TRUE), True);
|
|
end;
|
|
if not ARunOnce then begin
|
|
Log(Format('Threads:'#9'%d', [seThreads.Value]), TRUE);
|
|
Log(Format('Repetitions:'#9'%d', [seRepetitions.Value]), TRUE);
|
|
Log(format('Total Requests:'#9'%d', [seThreads.Value * seRepetitions.Value]), TRUE);
|
|
end;
|
|
Log('-----------------------------------------------------', TRUE);
|
|
Log('', TRUE);
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.WriteSequentialStressStart(TestName: string; const ExtraInfo: string);
|
|
begin
|
|
WriteTestInfo(False);
|
|
Log(Format('Starting %s test. %d repetitions %s', [testname, seRepetitions.Value, ExtraInfo]), TRUE);
|
|
fLogEnabledStatus := cbEnableLog.Checked;
|
|
cbEnableLog.Checked := FALSE;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.WriteSequentialStressEnd(TotalTime, Errors: integer);
|
|
var
|
|
reqsecond: double;
|
|
begin
|
|
reqsecond := GetRequestsPerSecond(TotalTime);
|
|
Log(Format('Test complete. %dms. %f Req/Second. %d Errors', [TotalTime, reqsecond, Errors]), TRUE);
|
|
cbEnableLog.Checked := fLogEnabledStatus;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.bbStressCustomClassClick(Sender: TObject);
|
|
begin
|
|
|
|
end;
|
|
|
|
{ TStressThread }
|
|
|
|
procedure TStressThread.BeforeDestroyThread;
|
|
begin
|
|
MegaDemoClientMainForm.NotifyThreadTermination(Self);
|
|
end;
|
|
|
|
constructor TStressThread.Create;
|
|
begin
|
|
inherited Create(TRUE);
|
|
FreeOnTerminate := TRUE;
|
|
end;
|
|
|
|
destructor TStressThread.Destroy;
|
|
begin
|
|
// Synchronize(BeforeDestroyThread);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TStressThread.Execute;
|
|
begin
|
|
Synchronize(Run);
|
|
end;
|
|
|
|
procedure TStressThread.Run;
|
|
var
|
|
svc: IMegaDemoService;
|
|
maxcount: integer;
|
|
i: integer;
|
|
begin
|
|
|
|
// Makes internal copies of the channel and the message
|
|
fMessage := CloneObject(MegaDemoClientMainForm.UserMessage) as TROMessage;
|
|
fChannel := CloneObject(MegaDemoClientMainForm.UserChannel) as TROTransportChannel;
|
|
try
|
|
svc := CoMegaDemoService.Create(fMessage, fChannel);
|
|
maxcount := MegaDemoClientMainForm.seRepetitions.Value - 1;
|
|
fTotalTime := 0;
|
|
|
|
with MegaDemoClientMainForm do try
|
|
if clbTests.Checked[1] then begin
|
|
for i := 0 to (maxcount - 1) do try
|
|
Inc(fSumTime, RunSum(svc));
|
|
except
|
|
Inc(fErrors);
|
|
end;
|
|
if Terminated then Exit;
|
|
end;
|
|
|
|
if clbTests.Checked[2] then begin
|
|
for i := 0 to (maxcount - 1) do try
|
|
Inc(fEchoPersonTime, RunEchoPerson(svc));
|
|
except
|
|
Inc(fErrors);
|
|
end;
|
|
|
|
if Terminated then Exit;
|
|
end;
|
|
|
|
if clbTests.Checked[3] then begin
|
|
for i := 0 to (maxcount - 1) do try
|
|
Inc(fArrayTime, int_RunTestArrays(svc, atInteger))
|
|
except
|
|
Inc(fErrors);
|
|
end;
|
|
if Terminated then Exit;
|
|
|
|
for i := 0 to (maxcount - 1) do try
|
|
Inc(fArrayTime, int_RunTestArrays(svc, atString))
|
|
except
|
|
Inc(fErrors);
|
|
end;
|
|
if Terminated then
|
|
Exit;
|
|
|
|
for i := 0 to (maxcount - 1) do try
|
|
Inc(fArrayTime, int_RunTestArrays(svc, atTPerson))
|
|
except
|
|
Inc(fErrors);
|
|
end;
|
|
if Terminated then Exit;
|
|
end;
|
|
|
|
if clbTests.Checked[4] then begin
|
|
for i := 0 to (maxcount - 1) do try
|
|
Inc(fEchoBinaryTime, RunEchoBinary(svc));
|
|
except
|
|
Inc(fErrors);
|
|
end;
|
|
if Terminated then Exit;
|
|
end;
|
|
|
|
if clbTests.Checked[5] then begin
|
|
for i := 0 to (maxcount - 1) do try
|
|
Inc(fGetServerTimeTime, RunServerTime(svc));
|
|
except
|
|
Inc(fErrors);
|
|
end;
|
|
if Terminated then Exit;
|
|
end;
|
|
|
|
if clbTests.Checked[6] then begin
|
|
for i := 0 to (maxcount - 1) do try
|
|
Inc(fCustomClassTime, RunCustomClass(svc));
|
|
except
|
|
Inc(fErrors);
|
|
end;
|
|
|
|
if Terminated then Exit;
|
|
end;
|
|
{
|
|
if clbTests.Checked[7] then begin
|
|
for i := 0 to (maxcount - 1) do try
|
|
Inc(fRaiseErrorTime, RunRaiseError(svc));
|
|
except
|
|
//Inc(fErrors);
|
|
end;
|
|
if Terminated then Exit;
|
|
end;
|
|
}
|
|
|
|
finally
|
|
fTotalTime := fSumTime +
|
|
fEchoPersonTime +
|
|
fArrayTime +
|
|
fEchoBinaryTime +
|
|
fGetServerTimeTime +
|
|
fCustomClassTime
|
|
// + fRaiseErrorTime +
|
|
;
|
|
Terminate;
|
|
end;
|
|
finally
|
|
fChannel.Free;
|
|
fMessage.Free;
|
|
BeforeDestroyThread;
|
|
|
|
end;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.cbHTTPURLChange(Sender: TObject);
|
|
begin
|
|
if Pos('/bin', cbHTTPURL.Text) > 0 then
|
|
rbBinary.Checked := true
|
|
else if Pos('/soap', cbHTTPURL.Text) > 0 then
|
|
rbSoap.Checked := true
|
|
else if Pos('/post', cbHTTPURL.Text) > 0 then
|
|
rbPost.Checked := true
|
|
else if Pos('/xmlrpc', cbHTTPURL.Text) > 0 then
|
|
rbXmlRpc.Checked := true;
|
|
cbUseCompression.Enabled := rbBinary.Checked;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.SOAPMessageWriteToStream(aStream: TStream);
|
|
begin
|
|
// memo1.Lines.LoadFromStream(aStream);
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.SOAPMessageEnvelopeComplete(Sender: TROSOAPMessage);
|
|
begin
|
|
sender.HeaderNode.Add('Test').Value := '1234';
|
|
if cbEnableLog.Checked then
|
|
memo1.Lines.Text := Sender.EnvelopeNode.XML;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.SOAPMessageReadFromStream(aStream: TStream);
|
|
begin
|
|
if cbEnableLog.Checked then Memo2.Lines.LoadFromStream(aStream);
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.BINMessageFinalizeMessage(Sender: TROMessage);
|
|
begin
|
|
if cbVerbose.Checked then Log(Sender.Name + ' is finalized');
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.BINMessageReadMessageParameter(Sender: TROMessage;
|
|
const aName: string; aTypeInfo: PTypeInfo; const DataRef: Pointer;
|
|
Attributes: TParamAttributes);
|
|
begin
|
|
if cbVerbose.Checked then begin
|
|
Log(Sender.Name + ' is reading ' + aName);
|
|
Log('');
|
|
end;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.BINMessageWriteMessageParameter(Sender: TROMessage;
|
|
const aName: string; aTypeInfo: PTypeInfo; const DataRef: Pointer;
|
|
Attributes: TParamAttributes);
|
|
begin
|
|
if cbVerbose.Checked then Log(Sender.Name + ' is writing ' + aName);
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.BINMessageInitializeMessage(Sender: TROMessage;
|
|
const aTransport: IROTransport; const anInterfaceName,
|
|
aMessageName: string);
|
|
begin
|
|
if cbVerbose.Checked then Log(Sender.Name + ' is initialized');
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.RunSum(aService: IMegaDemoService): integer;
|
|
begin
|
|
Result := InvokeSum(aService, seA.Value, seB.Value);
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.RunEchoPerson(aService: IMegaDemoService): integer;
|
|
begin
|
|
Result := InvokeEchoPerson(
|
|
aService,
|
|
eFirstName.Text,
|
|
eLastName.Text,
|
|
seAge.Value,
|
|
TSex(cbSex.ItemIndex));
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.RunRaiseError(aService: IMegaDemoService): integer;
|
|
begin
|
|
Result := InvokeRaiseError(aService);
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.Stress(AMethod: TStressMethod);
|
|
var
|
|
tot, errors, i: integer;
|
|
svc: IMegaDemoService;
|
|
begin
|
|
tot := 0;
|
|
errors := 0;
|
|
svc := CreateService;
|
|
WriteSequentialStressStart(clbTests.Items[clbTests.ItemIndex]);
|
|
for i := 1 to (seRepetitions.Value) do try
|
|
Inc(tot, AMethod(svc));
|
|
if (i mod 10 = 0) then Application.ProcessMessages;
|
|
if fTerminateTest then Break;
|
|
except
|
|
Inc(errors);
|
|
end;
|
|
WriteSequentialStressEnd(tot, errors);
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.RunTestArrays(aService: IMegaDemoService): integer;
|
|
begin
|
|
Result := 0;
|
|
if rbInteger.Checked then
|
|
Result := int_RunTestArrays(aService, atInteger)
|
|
else if rbString.Checked then
|
|
Result := int_RunTestArrays(aService, atString)
|
|
else if rbTPerson.Checked then
|
|
Result := int_RunTestArrays(aService, atTPerson);
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.RunEchoBinary(aService: IMegaDemoService): integer;
|
|
begin
|
|
Result := InvokeEchoBinary(aService, seBinSize.Value);
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.RunServerTime(aService: IMegaDemoService): integer;
|
|
begin
|
|
Result := InvokeGetServerTime(aService);
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.RunCustomClass(aService: IMegaDemoService): integer;
|
|
begin
|
|
Result := InvokeCustomClass(aService, rbStream.Checked);
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.clbTestsClick(Sender: TObject);
|
|
|
|
procedure HidePanels;
|
|
begin
|
|
pStress.Visible := False;
|
|
pSum.Visible := False;
|
|
pEchoPerson.Visible := False;
|
|
pTestArrays.Visible := False;
|
|
pEchoBinary.Visible := False;
|
|
pGetServerTime.Visible := False;
|
|
pCustomClass.Visible := False;
|
|
pRaiseError.Visible := False;
|
|
end;
|
|
|
|
var
|
|
t_panel: TPanel;
|
|
begin
|
|
HidePanels;
|
|
case clbTests.ItemIndex of
|
|
1: t_panel := pSum;
|
|
2: t_panel := pEchoPerson;
|
|
3: t_panel := pTestArrays;
|
|
4: t_panel := pEchoBinary;
|
|
5: t_panel := pGetServerTime;
|
|
6: t_panel := pCustomClass;
|
|
7: t_panel := pRaiseError;
|
|
else
|
|
t_panel := pStress;
|
|
end;
|
|
t_panel.Parent := pPage;
|
|
t_panel.Visible := True;
|
|
|
|
if clbTests.ItemIndex = 0 then begin
|
|
RunTestOnceButton.Caption := 'Run Stress Test';
|
|
RunTestButton.Caption := 'Stop Stress Test';
|
|
RunTestOnceButton.Hint := 'Run Stress Test';
|
|
RunTestButton.Hint := 'Stop Stress Test';
|
|
end
|
|
else begin
|
|
RunTestOnceButton.Caption := 'Run Test once';
|
|
RunTestButton.Caption := 'Run Test';
|
|
RunTestOnceButton.Hint := 'Starts the chosen test once';
|
|
RunTestButton.Hint := 'Starts the chosen test some times';
|
|
end;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.RunTestOnceButtonClick(Sender: TObject);
|
|
var
|
|
serv: IMegaDemoService;
|
|
s: string;
|
|
begin
|
|
s := '';
|
|
if clbTests.ItemIndex > 0 then begin
|
|
clbTests.Checked[clbTests.ItemIndex] := True;
|
|
serv := CreateService;
|
|
WriteTestInfo(True);
|
|
Screen.Cursor := crHourGlass;
|
|
end;
|
|
try
|
|
case clbTests.ItemIndex of
|
|
0: RunAllDemo;
|
|
1: begin
|
|
RunSum(serv);
|
|
s := 'Sum';
|
|
end;
|
|
2: begin
|
|
RunEchoPerson(serv);
|
|
s := 'EchoPerson';
|
|
end;
|
|
3: begin
|
|
RunTestArrays(serv);
|
|
s := 'TestArrays';
|
|
end;
|
|
4: begin
|
|
RunEchoBinary(serv);
|
|
s := 'EchoBinary';
|
|
end;
|
|
5: begin
|
|
RunServerTime(serv);
|
|
s := 'ServerTime';
|
|
end;
|
|
6: begin
|
|
RunCustomClass(serv);
|
|
s := 'CustomClass';
|
|
end;
|
|
7: begin
|
|
RunRaiseError(serv);
|
|
S := 'RaiseError';
|
|
end;
|
|
end;
|
|
finally
|
|
if clbTests.ItemIndex > 0 then Screen.Cursor := crDefault;
|
|
end;
|
|
if (s <> '') and not cbEnableLog.Checked then Log(s + ':'#9'Done', True);
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.RunAllDemo;
|
|
var
|
|
i: integer;
|
|
trd: TStressThread;
|
|
begin
|
|
Beep;
|
|
if (
|
|
(seRepetitions.Value > 10) and
|
|
(MessageDlg(msgWarningPorts, mtWarning, [mbOK, mbCancel], 0) <> mrOK)
|
|
) then
|
|
Exit;
|
|
|
|
Screen.Cursor := crHourGlass;
|
|
cbEnableLog.Checked := FALSE;
|
|
fTerminateTest := FALSE;
|
|
MegaDemoClientMainForm.CreateService;
|
|
// Makes sure UserChannel and UserMessage are set. The threads will reference them in their constructor
|
|
WriteTestInfo(False);
|
|
try
|
|
Log(Format('Sum test:'#9#9 + '%s', [BoolToStr(clbTests.Checked[1], TRUE)]), TRUE);
|
|
Log(Format('EchoPerson test:'#9 + '%s', [BoolToStr(clbTests.Checked[2], TRUE)]), TRUE);
|
|
// Log('RaiseError test:'#9+'%s', [BoolToStr(clbTests.Checked[3], TRUE)], -1, TRUE);
|
|
Log(Format('Array test:'#9#9 + '%s (%d items)', [BoolToStr(clbTests.Checked[4], TRUE), seArrayCount.Value]), TRUE);
|
|
Log(Format('EchoBinary test:'#9 + '%s (%d bytes)', [BoolToStr(clbTests.Checked[5], TRUE), seBinSize.Value]), TRUE);
|
|
Log(Format('GetServerTime test:'#9 + '%s', [BoolToStr(clbTests.Checked[6], TRUE)]), TRUE);
|
|
Log(Format('CustomClass test:'#9 + '%s (Use XML=%s)', [BoolToStr(clbTests.Checked[7], TRUE), BoolToStr(rbXML.Checked, TRUE)]), TRUE);
|
|
|
|
Log('', TRUE);
|
|
Log('Starting mega test');
|
|
Log('', TRUE);
|
|
|
|
for i := 1 to seThreads.Value do begin
|
|
trd := TStressThread.Create;
|
|
trd.idx := fThreads.Add(trd);
|
|
end;
|
|
|
|
Caption := Application.Title + Format(' (%d threads running)', [fThreads.Count]);
|
|
|
|
fMegaTestStart := GetTickCount;
|
|
for i := 0 to seThreads.Value - 1 do
|
|
TStressThread(fThreads[i]).Resume;
|
|
|
|
finally
|
|
// Screen.Cursor := crDefault;
|
|
end;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.StopAllDemo;
|
|
var
|
|
i: integer;
|
|
begin
|
|
fCritical.Enter;
|
|
try
|
|
for i := 0 to (fThreads.Count - 1) do
|
|
TThread(fThreads[i]).Terminate;
|
|
finally
|
|
fCritical.Leave;
|
|
end;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.RunTestButtonClick(Sender: TObject);
|
|
begin
|
|
Screen.Cursor := crHourGlass;
|
|
try
|
|
if clbTests.ItemIndex > 0 then
|
|
clbTests.Checked[clbTests.ItemIndex] := True;
|
|
case clbTests.ItemIndex of
|
|
0: StopAllDemo;
|
|
1: Stress(RunSum);
|
|
2: Stress(RunEchoPerson);
|
|
3: Stress(RunTestArrays);
|
|
4: Stress(RunEchoBinary);
|
|
5: Stress(RunServerTime);
|
|
6: Stress(RunCustomClass);
|
|
7: Stress(RunRaiseError);
|
|
end;
|
|
finally
|
|
Screen.Cursor := crDefault;
|
|
end;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.FormShow(Sender: TObject);
|
|
begin
|
|
pagecontrol2.Visible := False;
|
|
clbTests.ItemIndex := 1;
|
|
clbTests.OnClick(clbTests);
|
|
cbHTTPURLChange(cbHTTPURL);
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.clbTestsClickCheck(Sender: TObject);
|
|
begin
|
|
Check_ListBoxClick(clbTests.ItemIndex = 0);
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.Check_ListBoxClick(isAllDemo: Boolean);
|
|
|
|
procedure SetMode(AMode: Boolean);
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := 1 to clbTests.Items.Count - 2 do
|
|
clbTests.Checked[i] := AMode;
|
|
end;
|
|
|
|
var
|
|
i: integer;
|
|
iChecked, iUnChecked: byte;
|
|
begin
|
|
if not isAllDemo then begin
|
|
iChecked := 0;
|
|
iUnChecked := 0;
|
|
for i := 1 to clbTests.Items.Count - 2 do begin
|
|
if clbTests.Checked[i] then
|
|
inc(iChecked)
|
|
else
|
|
inc(iUnChecked);
|
|
end;
|
|
if iChecked = 0 then
|
|
clbTests.State[0] := cbUnchecked
|
|
else if iUnChecked = 0 then
|
|
clbTests.State[0] := cbChecked
|
|
else
|
|
clbTests.State[0] := cbGrayed;
|
|
end
|
|
else begin
|
|
case clbTests.State[0] of
|
|
cbUnchecked: SetMode(False);
|
|
cbChecked: SetMode(True);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TMegaDemoClientMainForm.int_RunTestArrays(aService: IMegaDemoService;
|
|
anArrayType: TArrayType): integer;
|
|
begin
|
|
Result := InvokeTestArray(aService, anArrayType, seArrayCount.Value);
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.Log(const aMessage: string;
|
|
Force: boolean);
|
|
begin
|
|
if cbEnableLog.Checked or Force then Memo.Lines.Add(AMessage);
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.LoadFromIni;
|
|
var
|
|
i: integer;
|
|
begin
|
|
with TINIFile.Create(ChangeFileExt(Application.EXEName, '.ini')) do try
|
|
ReadSectionValues('IPs', cbTCPIP.Items);
|
|
for i := 0 to (cbTCPIP.Items.Count - 1) do
|
|
cbTCPIP.Items[i] := cbTCPIP.Items.Values[cbTCPIP.Items.Names[i]];
|
|
|
|
ReadSectionValues('HTTP Urls', cbHTTPURL.Items);
|
|
for i := 0 to (cbHTTPURL.Items.Count - 1) do
|
|
cbHTTPURL.Items[i] := cbHTTPURL.Items.Values[cbHTTPURL.Items.Names[i]];
|
|
ReadSectionValues('Ports', cbTCPPort.Items);
|
|
for i := 0 to (cbTCPPort.Items.Count - 1) do
|
|
cbTCPPort.Items[i] := cbTCPPort.Items.Values[cbTCPPort.Items.Names[i]];
|
|
|
|
cbHTTPURL.Text := ReadString('Misc', 'HTTP URL', 'http://localhost:8099/bin');
|
|
cbHTTPURLChange(nil);
|
|
|
|
eServerID.Text := ReadString('Misc', 'Server ID', '{E46A5995-2260-44EA-AC60-121ADB4CC2D0}');
|
|
cbTCPIP.Text := ReadString('Misc', 'TCP Address', '127.0.0.1');
|
|
cbTCPPort.Text := ReadString('Misc', 'TCP Port', '8090');
|
|
rbIndyHttp.Checked := ReadBool('Misc', 'Indy HTTP', FALSE);
|
|
rbWinInetHttp.Checked := ReadBool('Misc', 'WinINet HTTP', TRUE);
|
|
rbSynapseHttp.Checked := ReadBool('Misc', 'Synapse HTTP', TRUE);
|
|
cbKeepConnection.Checked := ReadBool('Misc', 'Keep Connection', FALSE);
|
|
cbDisableNagle.Checked := ReadBool('Misc', 'Disable Nagle', FALSE);
|
|
cbEncrypt.Checked := ReadBool('Misc', 'Encryption Communication', FALSE);
|
|
cbEncryptClick(cbEncrypt);
|
|
seThreads.Value := ReadInteger('Misc', 'Threads', 5);
|
|
seRepetitions.Value := ReadInteger('Misc', 'Repetitions', 10);
|
|
|
|
cbWriteTestInfo.Checked := ReadBool('Misc', 'Write Test Info', True);
|
|
rbXML.Checked := ReadBool('Misc', 'CustomClass as XML', FALSE);
|
|
rbStream.Checked := not rbXML.Checked;
|
|
cbEnableLog.Checked := ReadBool('Misc', 'Enable Log', TRUE);
|
|
cbVerbose.Checked := ReadBool('Misc', 'Verbose', True);
|
|
clbTests.Checked[1] := ReadBool('Misc', 'Test Sum', TRUE);
|
|
clbTests.Checked[2] := ReadBool('Misc', 'Test EchoPerson', TRUE);
|
|
clbTests.Checked[3] := ReadBool('Misc', 'Test TestArrays', TRUE);
|
|
clbTests.Checked[4] := ReadBool('Misc', 'Test EchoBinary', TRUE);
|
|
clbTests.Checked[5] := ReadBool('Misc', 'Test GetServerTime', TRUE);
|
|
clbTests.Checked[6] := ReadBool('Misc', 'Test CustomClass', TRUE);
|
|
clbTests.Checked[7] := ReadBool('Misc', 'Test RaiseError', TRUE);
|
|
Check_ListBoxClick(False);
|
|
finally
|
|
Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.SaveToIni;
|
|
var
|
|
i: integer;
|
|
begin
|
|
with TINIFile.Create(ChangeFileExt(Application.EXEName, '.ini')) do try
|
|
for i := 0 to (cbTCPIP.Items.Count - 1) do
|
|
WriteString('IPs', IntToStr(i), cbTCPIP.Items[i]);
|
|
|
|
for i := 0 to (cbHTTPURL.Items.Count - 1) do
|
|
WriteString('HTTP Urls', IntToStr(i), cbHTTPURL.Items[i]);
|
|
|
|
for i := 0 to (cbTCPPort.Items.Count - 1) do
|
|
WriteString('Ports', IntToStr(i), cbTCPPort.Items[i]);
|
|
|
|
WriteString('Misc', 'HTTP URL', cbHTTPURL.Text);
|
|
WriteString('Misc', 'Server ID', eServerID.Text);
|
|
WriteString('Misc', 'TCP Address', cbTCPIP.Text);
|
|
WriteString('Misc', 'TCP Port', cbTCPPort.Text);
|
|
WriteBool('Misc', 'Indy HTTP', rbIndyHttp.Checked);
|
|
WriteBool('Misc', 'WinINet HTTP', rbWinInetHttp.Checked);
|
|
WriteBool('Misc', 'Synapse HTTP', rbSynapseHttp.Checked);
|
|
|
|
WriteBool('Misc', 'Keep Connection', cbKeepConnection.Checked);
|
|
WriteBool('Misc', 'Disable Nagle', cbDisableNagle.Checked);
|
|
WriteBool('Misc', 'Encryption Communication', cbEncrypt.Checked);
|
|
WriteInteger('Misc', 'Threads', seThreads.Value);
|
|
WriteInteger('Misc', 'Repetitions', seRepetitions.Value);
|
|
|
|
WriteBool('Misc', 'Write Test Info', cbWriteTestInfo.Checked);
|
|
WriteBool('Misc', 'CustomClass as XML', rbXML.Checked);
|
|
WriteBool('Misc', 'Enable Log', cbEnableLog.Checked);
|
|
WriteBool('Misc', 'Verbose', cbVerbose.Checked);
|
|
WriteBool('Misc', 'Test Sum', clbTests.Checked[1]);
|
|
WriteBool('Misc', 'Test EchoPerson', clbTests.Checked[2]);
|
|
WriteBool('Misc', 'Test TestArrays', clbTests.Checked[3]);
|
|
WriteBool('Misc', 'Test EchoBinary', clbTests.Checked[4]);
|
|
WriteBool('Misc', 'Test GetServerTime', clbTests.Checked[5]);
|
|
WriteBool('Misc', 'Test CustomClass', clbTests.Checked[6]);
|
|
WriteBool('Misc', 'Test RaiseError', clbTests.Checked[7]);
|
|
finally
|
|
Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.rbHttpChannelClick(Sender: TObject);
|
|
begin
|
|
cbAutoDetect.Enabled := Sender = rbHttpChannel;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.FormDeactivate(Sender: TObject);
|
|
begin
|
|
//
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.rbIndyHttpClick(Sender: TObject);
|
|
begin
|
|
cbKeepConnection.Enabled := rbWinInetHttp.Checked;
|
|
cbKeepConnection.Checked := rbWinInetHttp.Checked;
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.rbXmlRpcClick(Sender: TObject);
|
|
begin
|
|
ChangeUrl('xmlrpc');
|
|
end;
|
|
|
|
procedure TMegaDemoClientMainForm.cbAutoDetectClick(Sender: TObject);
|
|
begin
|
|
if rbBinary.Checked then rbBinaryClick(rbBinary)
|
|
else if rbPost.Checked then rbPostClick(rbPost)
|
|
else if rbXMLRpc.Checked then rbXmlRpcClick(rbXMLRpc)
|
|
else rbSOAPClick(rbSOAP);
|
|
end;
|
|
|
|
initialization
|
|
CoInitializeEx(nil, COINIT_MULTITHREADED);
|
|
finalization
|
|
CoUninitialize;
|
|
end.
|
|
|