david
fff1b2a4dc
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.SDAC@3 6f543ec7-021b-7e4c-98c9-62eafc7fb9a8
383 lines
9.5 KiB
ObjectPascal
383 lines
9.5 KiB
ObjectPascal
unit Threads;
|
|
|
|
interface
|
|
|
|
uses
|
|
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
|
StdCtrls, ExtCtrls, Db, MemDS, DBCtrls, ActiveX,
|
|
Grids, DBGrids, DBAccess, MSAccess, SdacVcl,
|
|
Buttons, ThreadsData, DemoFrame;
|
|
|
|
const
|
|
WM_ENDTHREAD = $500;
|
|
WM_EXCEPTTHREAD = $501;
|
|
WM_ENDEXECUTE = $502;
|
|
|
|
type
|
|
TThreadsFrame = class(TDemoFrame)
|
|
Timer: TTimer;
|
|
MSDataSource: TDataSource;
|
|
scDeleteAll: TMSSQL;
|
|
Panel3: TPanel;
|
|
Splitter2: TSplitter;
|
|
Panel4: TPanel;
|
|
meSQL: TMemo;
|
|
meLog: TMemo;
|
|
DBGrid1: TDBGrid;
|
|
Panel2: TPanel;
|
|
Panel5: TPanel;
|
|
btStart: TSpeedButton;
|
|
btStop: TSpeedButton;
|
|
btRun: TSpeedButton;
|
|
btRunMax: TSpeedButton;
|
|
btClearLog: TSpeedButton;
|
|
Panel6: TPanel;
|
|
btOpen: TSpeedButton;
|
|
btDeleteAll: TSpeedButton;
|
|
DBNavigator1: TDBNavigator;
|
|
Panel11: TPanel;
|
|
Panel10: TPanel;
|
|
Label1: TLabel;
|
|
Label2: TLabel;
|
|
lbThreadCount: TLabel;
|
|
lbExceptCount: TLabel;
|
|
Panel12: TPanel;
|
|
lbInterval: TLabel;
|
|
lbTime: TLabel;
|
|
Label5: TLabel;
|
|
Label6: TLabel;
|
|
Panel13: TPanel;
|
|
Panel14: TPanel;
|
|
Label3: TLabel;
|
|
edCount: TEdit;
|
|
Panel9: TPanel;
|
|
Label4: TLabel;
|
|
rbInsert: TRadioButton;
|
|
rbSelect: TRadioButton;
|
|
meErrorLog: TMemo;
|
|
MSQuery: TMSQuery;
|
|
procedure btRunClick(Sender: TObject);
|
|
procedure TimerTimer(Sender: TObject);
|
|
procedure btStartClick(Sender: TObject);
|
|
procedure btStopClick(Sender: TObject);
|
|
procedure edCountChange(Sender: TObject);
|
|
procedure btRunMaxClick(Sender: TObject);
|
|
procedure btClearLogClick(Sender: TObject);
|
|
procedure btOpenClick(Sender: TObject);
|
|
procedure rgModeClick(Sender: TObject);
|
|
procedure btDeleteAllClick(Sender: TObject);
|
|
procedure Button1Click(Sender: TObject);
|
|
|
|
private
|
|
procedure WMEndExecute(var Msg: TMessage); message WM_ENDTHREAD;
|
|
procedure WMException(var Msg: TMessage); message WM_EXCEPTTHREAD;
|
|
|
|
function RunThread(ObjectPtr: pointer; Method:pointer; EndMethod: pointer): THandle;
|
|
|
|
procedure Execute;
|
|
procedure EndExecute(Result: boolean);
|
|
|
|
procedure Log(St: string);
|
|
procedure ErrorLog(St: string);
|
|
|
|
procedure TestConnected;
|
|
|
|
public
|
|
// Demo management
|
|
procedure Initialize; override;
|
|
procedure SetDebug(Value: boolean); override;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
{$IFNDEF VER130}Variants,{$ENDIF}
|
|
SdacDemoForm;
|
|
|
|
{$WRITEABLECONST ON}
|
|
|
|
{$R *.dfm}
|
|
|
|
const
|
|
MaxThread: integer = 40;
|
|
Interval: integer = 2000;
|
|
ExceptCount: integer = 0;
|
|
|
|
var
|
|
ThreadCount: integer;
|
|
ThreadNum: integer;
|
|
hCountSec: TRTLCriticalSection;
|
|
hLogSec: TRTLCriticalSection;
|
|
BegTime: TDateTime;
|
|
|
|
type
|
|
TMethod = procedure (Self: pointer);
|
|
TEndMethod = procedure (Self: pointer; Result: boolean);
|
|
|
|
PMethodDesc = ^TMethodDesc;
|
|
TMethodDesc = record
|
|
ObjectPtr :pointer;
|
|
Method :pointer;
|
|
EndMethod :pointer;
|
|
hWindow :HWND;
|
|
end;
|
|
|
|
procedure ThreadProc(MethodDesc: PMethodDesc); stdcall;
|
|
begin
|
|
try
|
|
TMethod(MethodDesc^.Method)(MethodDesc.ObjectPtr);
|
|
PostMessage(MethodDesc.hWindow, WM_ENDTHREAD, DWORD(MethodDesc), 0);
|
|
except
|
|
on E:Exception do begin
|
|
PostMessage(MethodDesc.hWindow, WM_EXCEPTTHREAD, DWORD(MethodDesc),
|
|
DWORD(E));
|
|
ExitThread(0);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TThreadsFrame.WMEndExecute(var Msg: TMessage);
|
|
begin
|
|
if PMethodDesc(Msg.wParam).EndMethod <> nil then
|
|
TEndMethod(PMethodDesc(Msg.wParam).EndMethod)(PMethodDesc(Msg.wParam).ObjectPtr, True);
|
|
Dispose(PMethodDesc(Msg.wParam));
|
|
end;
|
|
|
|
procedure TThreadsFrame.WMException(var Msg: TMessage);
|
|
begin
|
|
if PMethodDesc(Msg.wParam).EndMethod <> nil then
|
|
TEndMethod(PMethodDesc(Msg.wParam).EndMethod)(PMethodDesc(Msg.wParam).ObjectPtr, False);
|
|
Dispose(PMethodDesc(Msg.wParam));
|
|
raise Exception(Msg.lParam);
|
|
end;
|
|
|
|
function TThreadsFrame.RunThread(ObjectPtr: pointer; Method: pointer; EndMethod: pointer): THandle;
|
|
var
|
|
ThreadId: DWORD;
|
|
MethodDesc: PMethodDesc;
|
|
begin
|
|
New(MethodDesc);
|
|
|
|
MethodDesc.ObjectPtr := ObjectPtr;
|
|
MethodDesc.Method := Method;
|
|
MethodDesc.EndMethod := EndMethod;
|
|
MethodDesc.hWindow := Handle;
|
|
|
|
InterlockedIncrement(ThreadCount);
|
|
Result:= CreateThread(nil, 1000, @ThreadProc, MethodDesc, 0, ThreadId);
|
|
end;
|
|
|
|
procedure TThreadsFrame.Log(St: string);
|
|
begin
|
|
EnterCriticalSection(hLogSec);
|
|
if meLog.Lines.Count > 1000 then
|
|
meLog.Lines.Clear;
|
|
meLog.Lines.Add(St);
|
|
LeaveCriticalSection(hLogSec);
|
|
end;
|
|
|
|
procedure TThreadsFrame.ErrorLog(St:string);
|
|
begin
|
|
EnterCriticalSection(hLogSec);
|
|
meErrorLog.Lines.Add(St);
|
|
LeaveCriticalSection(hLogSec);
|
|
end;
|
|
|
|
const
|
|
Delay = 1000;
|
|
|
|
procedure TThreadsFrame.Execute;
|
|
var
|
|
Data: TdmThreadsData;
|
|
ThreadNum: integer;
|
|
i: integer;
|
|
begin
|
|
i := CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
|
|
if i <> S_OK then
|
|
raise Exception.Create('err - ' + IntToStr(i));
|
|
|
|
EnterCriticalSection(hCountSec);
|
|
Inc(Threads.ThreadNum);
|
|
ThreadNum := Threads.ThreadNum;
|
|
lbThreadCount.Caption := IntToStr(ThreadCount);
|
|
LeaveCriticalSection(hCountSec);
|
|
|
|
Data := TdmThreadsData.Create(nil);
|
|
try
|
|
try
|
|
with Data do begin
|
|
Log(IntToStr(ThreadNum) + ' Connecting...');
|
|
MSConnection.Assign(SdacForm.MSConnection);
|
|
MSConnection.LoginPrompt := False;
|
|
MSConnection.Connect;
|
|
Log(IntToStr(ThreadNum) + ' Connected');
|
|
|
|
if rbInsert.Checked then begin
|
|
// INSERT
|
|
MSSQL.ParamByName('ID').AsInteger := Random(10000);
|
|
MSSQL.Execute;
|
|
// MSConnection.Commit;
|
|
Log(IntToStr(ThreadNum) + ' Executed');
|
|
end
|
|
else begin
|
|
// SELECT
|
|
MSQuery.Open;
|
|
i := 0;
|
|
while not MSQuery.Eof do begin
|
|
MSQuery.Next;
|
|
Inc(i);
|
|
end;
|
|
Log(IntToStr(ThreadNum) + ' Fetched ' + IntToStr(i) + ' rows');
|
|
MSQuery.Close;
|
|
end;
|
|
|
|
MSConnection.Disconnect;
|
|
Log(IntToStr(ThreadNum) + ' Disconnected');
|
|
end;
|
|
except
|
|
on E:Exception do begin
|
|
MessageBeep(1000);
|
|
Log(IntToStr(ThreadNum) + ' ' + IntToStr(ThreadCount) + ' Exception ' + E.Message);
|
|
ErrorLog(IntToStr(ThreadNum) + ' ' + IntToStr(ThreadCount) + ' Exception ' + E.Message);
|
|
Inc(ExceptCount);
|
|
lbExceptCount.Caption := IntToStr(ExceptCount);
|
|
end;
|
|
end;
|
|
finally
|
|
Data.Free;
|
|
CoUninitialize;
|
|
end;
|
|
end;
|
|
|
|
procedure TThreadsFrame.EndExecute(Result: boolean);
|
|
begin
|
|
InterlockedDecrement(ThreadCount);
|
|
EnterCriticalSection(hCountSec);
|
|
lbThreadCount.Caption := IntToStr(ThreadCount);
|
|
MessageBeep(1000);
|
|
LeaveCriticalSection(hCountSec);
|
|
end;
|
|
|
|
procedure TThreadsFrame.btRunClick(Sender: TObject);
|
|
begin
|
|
TestConnected;
|
|
RunThread(Self, @TThreadsFrame.Execute, @TThreadsFrame.EndExecute);
|
|
end;
|
|
|
|
procedure TThreadsFrame.btRunMaxClick(Sender: TObject);
|
|
var
|
|
i: integer;
|
|
begin
|
|
TestConnected;
|
|
for i := 1 to MaxThread do
|
|
RunThread(Self, @TThreadsFrame.Execute, @TThreadsFrame.EndExecute);
|
|
end;
|
|
|
|
procedure TThreadsFrame.btStartClick(Sender: TObject);
|
|
begin
|
|
TestConnected;
|
|
edCount.Text := IntToStr(MaxThread);
|
|
BegTime := Time;
|
|
TimerTimer(nil);
|
|
end;
|
|
|
|
procedure TThreadsFrame.btStopClick(Sender: TObject);
|
|
begin
|
|
Timer.Enabled := False;
|
|
end;
|
|
|
|
procedure TThreadsFrame.TimerTimer(Sender: TObject);
|
|
begin
|
|
if ThreadCount < MaxThread then begin
|
|
btRunClick(nil);
|
|
if ThreadCount < (MaxThread div 10) * 9 then
|
|
Dec(Interval, Interval div 10);
|
|
end
|
|
else
|
|
Inc(Interval, Interval div 10);
|
|
|
|
lbInterval.Caption := IntToStr(Interval);
|
|
lbExceptCount.Caption := IntToStr(ExceptCount);
|
|
Timer.Interval := Random(Interval - 1) + 1;
|
|
lbTime.Caption := TimeToStr(Time - BegTime);
|
|
|
|
lbInterval.Caption := lbInterval.Caption + ' / ' + IntToStr(Timer.Interval);
|
|
|
|
Timer.Enabled := True;
|
|
end;
|
|
|
|
procedure TThreadsFrame.edCountChange(Sender: TObject);
|
|
begin
|
|
MaxThread := StrToInt(edCount.Text);
|
|
end;
|
|
|
|
procedure TThreadsFrame.btClearLogClick(Sender: TObject);
|
|
begin
|
|
meLog.Lines.Clear;
|
|
meErrorLog.Lines.Clear;
|
|
ThreadNum := 0;
|
|
ExceptCount := 0;
|
|
lbExceptCount.Caption := IntToStr(ExceptCount);
|
|
end;
|
|
|
|
procedure TThreadsFrame.btOpenClick(Sender: TObject);
|
|
begin
|
|
MSQuery.Close;
|
|
MSQuery.Open;
|
|
end;
|
|
|
|
procedure TThreadsFrame.rgModeClick(Sender: TObject);
|
|
begin
|
|
if rbInsert.Checked then
|
|
meSQL.Lines.Assign(dmThreadsData.MSSQL.SQL)
|
|
else
|
|
meSQL.Lines.Assign(dmThreadsData.MSQuery.SQL)
|
|
end;
|
|
|
|
procedure TThreadsFrame.btDeleteAllClick(Sender: TObject);
|
|
begin
|
|
scDeleteAll.Execute;
|
|
// MSConnection.Commit;
|
|
end;
|
|
|
|
procedure TThreadsFrame.Button1Click(Sender: TObject);
|
|
begin
|
|
Execute;
|
|
end;
|
|
|
|
procedure TThreadsFrame.TestConnected;
|
|
begin
|
|
SdacForm.MSConnection.Connect;
|
|
if not SdacForm.MSConnection.Connected then
|
|
Abort;
|
|
end;
|
|
|
|
// Demo management
|
|
procedure TThreadsFrame.Initialize;
|
|
begin
|
|
inherited;
|
|
MSQuery.Connection := Connection as TMSConnection;
|
|
dmThreadsData := TdmThreadsData.Create(Self);
|
|
edCount.Text := IntToStr(MaxThread);
|
|
rbInsert.Checked := True;
|
|
end;
|
|
|
|
procedure TThreadsFrame.SetDebug(Value: boolean);
|
|
begin
|
|
MSQuery.Debug := Value;
|
|
end;
|
|
|
|
initialization
|
|
|
|
// We are using Windows threading (vs Delphi TThread), so we need to enable IsMultiThread
|
|
IsMultiThread := True;
|
|
|
|
InitializeCriticalSection(hCountSec);
|
|
InitializeCriticalSection(hLogSec);
|
|
Randomize;
|
|
finalization
|
|
DeleteCriticalSection(hCountSec);
|
|
DeleteCriticalSection(hLogSec);
|
|
end.
|
|
|