main.pas

ODAC 5.7.0.28

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Ora, Data, ExtCtrls, OraClasses, OraScript, Db, MemDS, DBCtrls,
  Grids, DBGrids, DBAccess, OdacVcl;

const
  WM_ENDTHREAD     = $500;
  WM_EXCEPTTHREAD  = $501;
  WM_ENDEXECUTE    = $502;

type
  TfmMain = class(TForm)
    btRun: TButton;
    Label1: TLabel;
    lbThreadCount: TLabel;
    meLog: TMemo;
    btStart: TButton;
    btStop: TButton;
    Timer: TTimer;
    lbInterval: TLabel;
    Label2: TLabel;
    lbExceptCount: TLabel;
    lbTime: TLabel;
    meErrorLog: TMemo;
    btRunMax: TButton;
    Label3: TLabel;
    btClearLog: TButton;
    meSQL: TMemo;
    edCount: TEdit;
    OraSession: TOraSession;
    DBGrid1: TDBGrid;
    DBNavigator1: TDBNavigator;
    btOpen: TButton;
    OraQuery: TOraQuery;
    scCreate: TOraScript;
    scDrop: TOraScript;
    btCreate: TButton;
    btDrop: TButton;
    OraDataSource: TOraDataSource;
    rgMode: TRadioGroup;
    btDeleteAll: TButton;
    procedure btRunClick(Sender: TObject);
    procedure TimerTimer(Sender: TObject);
    procedure btStartClick(Sender: TObject);
    procedure btStopClick(Sender: TObject);
    procedure edCountChange(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure btRunMaxClick(Sender: TObject);
    procedure btClearLogClick(Sender: TObject);
    procedure btOpenClick(Sender: TObject);
    procedure btCreateClick(Sender: TObject);
    procedure btDropClick(Sender: TObject);
    procedure rgModeClick(Sender: TObject);
    procedure btDeleteAllClick(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);

  public
  end;

var
  fmMain: TfmMain;

implementation
uses
  OraCall, Debug
  {$IFNDEF VER130}, Variants{$ENDIF};

{$R *.DFM}
var
  ThreadCount:integer;
  ThreadNum:integer;
  hCountSec:TRTLCriticalSection;
  BegTime:TDateTime;
  MaxThread: integer;
  Interval: integer;
  ExceptCount: integer;


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 TfmMain.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 TfmMain.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 TfmMain.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;

  Result:= CreateThread(nil, 1000, @ThreadProc, MethodDesc, 0, ThreadId);
end;

procedure TfmMain.Log(St: string);
begin
  if meLog.Lines.Count > 1000 then
    meLog.Lines.Clear;
  meLog.Lines.Add(St);
end;

procedure TfmMain.ErrorLog(St:string);
begin
  meErrorLog.Lines.Add(St);
end;

const
  Delay = 1000;

procedure TfmMain.Execute;
var
  Data: TdmData;
  ThreadNum: integer;
  i: integer;
begin
  EnterCriticalSection(hCountSec);
    Inc(ThreadCount);
    Inc(Main.ThreadNum);
    ThreadNum := Main.ThreadNum;
    lbThreadCount.Caption := IntToStr(ThreadCount);
  LeaveCriticalSection(hCountSec);

  Data := TdmData.Create(nil);
  try
  try
    with Data do begin
      Log(IntToStr(ThreadNum) + ' Connecting...');
        OraSession.Assign(Self.OraSession);
        OraSession.ConnectPrompt := false;
        OraSession.Connect;
      Log(IntToStr(ThreadNum) + ' Connected');

      if rgMode.ItemIndex = 0 then begin
      // INSERT
        OraSQL.ParamByName('ID').AsInteger := Random(10000);
        OraSQL.Execute;
        OraSession.Commit;
        Log(IntToStr(ThreadNum) + ' Executed');
      end
      else begin
      // SELECT
        OraQuery.Open;
        i := 0;
        while not OraQuery.Eof do begin
          OraQuery.Next;
          Inc(i);
        end;
        Log(IntToStr(ThreadNum) + ' Fetched ' + IntToStr(i) + ' rows');
        OraQuery.Close;
      end;

      OraSession.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;
  end;
end;

procedure TfmMain.EndExecute(Result: boolean);
begin
  EnterCriticalSection(hCountSec);
  Dec(ThreadCount);
  lbThreadCount.Caption := IntToStr(ThreadCount);
  MessageBeep(1000);
  LeaveCriticalSection(hCountSec);
end;

procedure TfmMain.FormShow(Sender: TObject);
begin
  edCount.Text := IntToStr(MaxThread);
  OraSession.Connect;
  rgMode.ItemIndex := 1;
end;

procedure TfmMain.btRunClick(Sender: TObject);
begin
  OraSession.Connect;
  if OraSession.Connected then
    RunThread(Self, @TfmMain.Execute, @TfmMain.EndExecute);
end;

procedure TfmMain.btRunMaxClick(Sender: TObject);
var
  i: integer;
begin
  OraSession.Connect;
  if OraSession.Connected then
    for i := 1 to MaxThread do
      RunThread(Self, @TfmMain.Execute, @TfmMain.EndExecute);
end;

procedure TfmMain.btStartClick(Sender: TObject);
begin
  edCount.Text := IntToStr(MaxThread);
  BegTime := Time;
  TimerTimer(nil);
end;

procedure TfmMain.btStopClick(Sender: TObject);
begin
  Timer.Enabled := False;
end;

procedure TfmMain.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 TfmMain.edCountChange(Sender: TObject);
begin
  MaxThread := StrToInt(edCount.Text);
end;

procedure TfmMain.btClearLogClick(Sender: TObject);
begin
  meLog.Lines.Clear;
  meErrorLog.Lines.Clear;
  ThreadNum := 0;
  ExceptCount := 0;
  lbExceptCount.Caption := IntToStr(ExceptCount);
end;

procedure TfmMain.btOpenClick(Sender: TObject);
begin
  OraQuery.Close;
  OraQuery.Open;
end;

procedure TfmMain.btCreateClick(Sender: TObject);
begin
  scCreate.Execute;
end;

procedure TfmMain.btDropClick(Sender: TObject);
begin
  scDrop.Execute;
end;

procedure TfmMain.rgModeClick(Sender: TObject);
begin
  if rgMode.ItemIndex = 0 then
    meSQL.Lines.Assign(dmData.OraSQL.SQL)
  else
    meSQL.Lines.Assign(dmData.OraQuery.SQL)
end;

procedure TfmMain.btDeleteAllClick(Sender: TObject);
begin
  OraSession.ExecSQL('DELETE FROM ThreadTable', [Null]);
  OraSession.Commit;
end;

initialization
  MaxThread := 5;
  Interval := 2000;
  ExceptCount := 0;

  InitializeCriticalSection(hCountSec);
  OraCall.OCIThreaded := True;
  OraCall.OCIMutexed := True;
  
  Randomize;
finalization
  DeleteCriticalSection(hCountSec);
end.