In order to test the performance of the application, receiving many requests at the same time, I created an application that, inside threads, opens a connection using the TDCOMConnection creates a TClientDataSet, associates ProviderName and Inserts, Updates and Deletes records at the same time.
But when i try access the server, I am getting the following error:
The application called an interface that was marshalled for a different thread.
What would that be?
Could you help me to solve this problem?
Unit1.pas:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtSvrConnect, ExtDBClient, SyncObjs, ActiveX;
type
//0 - Executing
//1 - Done
//TMsg Adress
PArray = ^TArray;
TArray = Array of Integer;
TCS = class(TMultiReadExclusiveWriteSynchronizer);
TMsg = class
public
Done: Boolean;
Strings: array of String;
end;
TWorker = class(TThread)
private
FOpt,
FQuantity,
FIndex: Integer;
FRef: PArray;
FCon: TExtSocketConnection;
FCds: TExtClientDataSet;
FMsg: TMsg;
protected
procedure OpenCds;
procedure CreateObjs;
procedure DestroyObjs;
procedure Execute; override;
public
constructor Create(Opt, Quantity, I: Integer; Pt: PArray);
end;
TForm1 = class(TForm)
Button1: TButton;
edQuantity: TEdit;
Memo1: TMemo;
edClients: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
Button2: TButton;
Label8: TLabel;
Label9: TLabel;
Label10: TLabel;
Label11: TLabel;
Label12: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
Workers : Array of TWorker;
Signals : TArray;
Size, Loop,
Opt, CountDone: Integer;
protected
procedure InitializeThreads;
procedure Reset;
procedure Initialize;
public
{ Public declarations }
end;
var
Form1: TForm1;
Cs: TCS;
implementation
uses DB;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
Reset;
Initialize;
Button2Click(Sender);
end;
procedure TForm1.InitializeThreads;
var I: Integer;
begin
for I:= 0 to Length(Signals)-1 do
Signals[I] := 0;
for I:= 0 to Length(Workers)-1 do
Workers[I] := TWorker.Create(Opt, Loop, I, @Signals);
for I:= 0 to Length(Workers)-1 do
Workers[I].Resume;
end;
procedure TForm1.Initialize;
begin
try
Size := StrToInt(edClients.Text);
if Size <= 0 then
raise Exception.Create('Value must be > 0');
except
//on EConvertError do
ShowMessage('Invalid Number!');
edClients.SetFocus;
end;
if Size > 0 then
begin
try
Loop := StrToInt(edQuantity.Text);
if Loop <= 0 then
raise Exception.Create('Value must be > 0');
except
//on EConvertError do
ShowMessage('Invalid Number!');
edQuantity.SetFocus;
end;
if Loop > 0 then
begin
while (Opt < 1) or (Opt > 4) do
try
Opt := StrToInt(InputBox('Choose.','Choose', '4'));
except
Opt := 0;
ShowMessage('Invalid Number!');
end;
SetLength(Workers, Size);
SetLength(Signals, Size);
InitializeThreads;
Label11.Caption := IntToStr(Size);
end;
end;
Button1.Enabled := (Size <= 0) or
(Loop <= 0);
end;
procedure TForm1.Reset;
begin
Label11.Caption := '0'; //created
Label12.Caption := '0'; //finalized
Label8.Caption := 'Threads terminated: 0';
Size := 0;
Loop := 0;
Opt := 0;
CountDone:= 0;
Memo1.Lines.Clear;
Button1.Enabled := False;
end;
{ TWorker }
constructor TWorker.Create(Opt, Quantity, I: Integer; Pt: PArray);
begin
inherited Create(True);
FOpt := Opt;
FQuantity := Quantity;
FIndex := I;
FRef := Pt;
FreeOnTerminate := True;
end;
procedure TWorker.CreateObjs;
begin
FMsg := TMsg.Create;
FCon := TExtSocketConnection.Create(nil);
FCon.Address := '127.0.0.1';
FCon.ConnectionName := 'ServerConn';
FCon.ComputerName := '127.0.0.1';
FCon.LoginPrompt := False;
FCon.ServerGUID := '{5CC58302-83A4-11D2-B28F-00E046600CDA}';
FCon.ServerName := 'ServerConn.ServerConnDat';
FCds := TExtClientDataSet.Create(nil);
FCds.FieldDefs.Add('Code', ftInteger, 0, True);
FCds.FieldDefs.Add('Code2', ftInteger, 0, True);
FCds.FieldDefs.Add('Year', ftInteger, 0, True);
FCds.FieldDefs.Add('Month', ftInteger, 0, True);
FCds.FieldDefs.Add('Amount', ftInteger, 0, True);
FCds.Params.CreateParam(ftInteger, 'Code', ptInput);
FCds.Params.CreateParam(ftInteger, 'Code2', ptInput);
FCds.RemoteServer := FCon;
FCds.ProviderName := 'prvYearMonth';
FCds.CreateDataSet;
end;
procedure TWorker.DestroyObjs;
begin
FCon.AppServer.Logout;
FCds.Free;
FCon.Free;
if Length(FMsg.Strings) = 0 then
FMsg.Free;
end;
procedure TWorker.Execute;
var I: Integer;
Y,M: Integer;
Entered: Boolean;
begin
inherited;
CoInitialize(nil);
CreateObjs;
Y := 2013;
M := 12;
try
OpenCds;
for I:= 0 To FQuantity-1 do
begin
try
//Insert
FCds.Append;
FCds.FieldByName('Code').AsInteger := 0;
FCds.FieldByName('Code2').AsInteger := 1;
FCds.FieldByName('Year').AsInteger := Y;
FCds.FieldByName('Month').AsInteger := M;
FCds.FieldByName('Amount').AsInteger := 99;
FCds.Post;
FCds.ApplyUpdates(0);
//Update
if FOpt > 2 then
begin
FCds.Last;
FCds.Edit;
FCds.FieldByName('Amount').AsInteger := 88;
FCds.Post;
FCds.ApplyUpdates(0);
end;
//delete
if (FOpt mod 2) = 0 then
begin
FCds.Last;
FCds.Delete;
FCds.ApplyUpdates(0);
end;
except
SetLength(FMsg.Strings, Length(FMsg.Strings)+1);
FMsg.Strings[Length(FMsg.Strings)-1] := 'Turn: '+IntToStr(I)+'. Msg: '+Exception(ExceptObject).Message;
end;
Inc(M);
if M = 13 then
begin
M := 1;
Inc(Y);
end;
end;
if Length(FMsg.Strings) > 0 then
begin
repeat Entered := Cs.BeginWrite;
until Entered; //Hint: Is this necessary??
try
FMsg.Done := True;
FRef^[FIndex] := Integer(FMsg);
finally Cs.EndWrite; end;
end
else
begin
repeat Entered := Cs.BeginWrite;
until Entered;
try
FRef^[FIndex] := 1;
finally Cs.EndWrite; end;
end;
finally
DestroyObjs;
CoUninitialize;
end;
end;
procedure TWorker.OpenCds;
begin
FCds.FetchParams;
FCds.RemoteServer.AppServer.Login();
FCds.Params.ParamByName('Code').AsInteger := 0;
FCds.Params.ParamByName('Code2').AsInteger := 1;
FCds.DataRequestAndOpen; //this will perform DataRequest and Open.
end;
procedure TForm1.Button2Click(Sender: TObject);
var I, J: Integer;
P: TMsg;
IsDone: Boolean;
Signal: Integer;
begin
for I:= 0 to Length(Signals)-1 do
begin
Cs.BeginRead;
try
Signal := Signals[I];
finally Cs.EndRead; end;
if Signal > 0 then
if Signal = 1 then
begin
Memo1.Lines.Add('Thread: '+IntToStr(I)+' Finished!');
Inc(CountDone);
end
else
begin
P:= TMsg(Signal);
Cs.BeginRead;
try
IsDone := P.Done;
finally Cs.EndRead; end;
if IsDone then
begin
for J := 0 to Length(P.Strings)-1 do
Memo1.Lines.Add('Thread: '+IntToStr(I)+' Threw an exception: '+ P.Strings[J]);
Inc(CountDone);
P.Free;
end;
end;
end;
if CountDone = Size then
begin
Label8.Caption := 'Finished';
Button1.Enabled := True;
end
else
Label8.Caption := 'Threads running :'+IntToStr(Size-CountDone);
Label12.Caption := IntToStr(CountDone);
end;
initialization
Cs := TCS.Create;
finalization
Cs.free;
end.
Unit1.dfm:
object Form1: TForm1
Left = 622
Top = 188
Width = 374
Height = 494
Caption = 'Test Performance'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 1
Top = 1
Width = 31
Height = 13
Caption = 'Clients'
end
object Label2: TLabel
Left = 125
Top = 3
Width = 39
Height = 13
Caption = 'Quantity'
end
object Label3: TLabel
Left = 10
Top = 120
Width = 30
Height = 13
Caption = 'Result'
end
object Label4: TLabel
Left = 3
Top = 50
Width = 38
Height = 13
Caption = '1- Insert'
end
object Label5: TLabel
Left = 3
Top = 65
Width = 81
Height = 13
Caption = '2- Insert e Delete'
end
object Label6: TLabel
Left = 3
Top = 95
Width = 110
Height = 13
Caption = '4- Insert Update Delete'
end
object Label7: TLabel
Left = 3
Top = 80
Width = 79
Height = 13
Caption = '3- Insert Update '
end
object Label8: TLabel
Left = 16
Top = 437
Width = 103
Height = 13
Caption = 'Threads terminated: 0'
Font.Charset = DEFAULT_CHARSET
Font.Color = clRed
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
end
object Label9: TLabel
Left = 264
Top = 56
Width = 37
Height = 13
Caption = 'Created'
Font.Charset = DEFAULT_CHARSET
Font.Color = clBlue
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
end
object Label10: TLabel
Left = 264
Top = 72
Width = 53
Height = 13
Caption = 'Terminated'
Font.Charset = DEFAULT_CHARSET
Font.Color = clGreen
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
end
object Label11: TLabel
Left = 320
Top = 56
Width = 28
Height = 13
AutoSize = False
Caption = '0'
Font.Charset = DEFAULT_CHARSET
Font.Color = clBlue
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
end
object Label12: TLabel
Left = 320
Top = 72
Width = 28
Height = 13
AutoSize = False
Caption = '0'
Font.Charset = DEFAULT_CHARSET
Font.Color = clGreen
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
end
object Button1: TButton
Left = 270
Top = 14
Width = 75
Height = 25
Caption = 'Run'
TabOrder = 0
OnClick = Button1Click
end
object edQuantity: TEdit
Left = 125
Top = 17
Width = 121
Height = 21
TabOrder = 1
Text = '10'
end
object Memo1: TMemo
Left = 10
Top = 136
Width = 337
Height = 281
ScrollBars = ssBoth
TabOrder = 2
end
object edClients: TEdit
Left = 1
Top = 18
Width = 121
Height = 21
TabOrder = 3
Text = '400'
end
object Button2: TButton
Left = 271
Top = 104
Width = 75
Height = 25
Caption = 'Check Now'
TabOrder = 4
OnClick = Button2Click
end
end
An apartment-threaded ActiveX/COM object can only be used in the same thread that it is created in. If you need to use such an object in another thread, it has to be marshalled to that thread using either CoMarshalInterThreadInterfaceInStream() or IGlobalInterfaceTable so ActiveX/COM can create a special proxy that delegates method calls to the original thread. Since you are using component wrappers, neither option is possible for you. So your only option is to create the component instances inside the Execute() method of the thread that is going to be using them, and don't forget to have Execute() call CoInitialize/Ex() first, eg:
procedure TMyThread.Execute;
var
Conn: TDCOMConnection;
DS: TClientDataSet;
begin
CoInitialize(nil);
try
Conn := TDCOMConnection.Create(nil);
try
DS := TClientDataSet.Create(nil);
try
...
finally
DS.Free;
end;
finally
Conn.Free;
end;
finally
CoUninitialize;
end;
end;