main.pas

ODAC+SDAC源代码

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls,  Data, ExtCtrls, Db, MemDS, DBCtrls, ActiveX,
  Grids, DBGrids, DBAccess, MSAccess, SdacVcl;

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;
    MSConnection: TMSConnection;
    DBGrid1: TDBGrid;
    DBNavigator1: TDBNavigator;
    btOpen: TButton;
    MSQuery: TMSQuery;
    scCreate: TMSSQL;
    scDrop: TMSSQL;
    btCreate: TButton;
    btDrop: TButton;
    MSDataSource: TDataSource;
    rgMode: TRadioGroup;
    btDeleteAll: TButton;
    scDeleteAll: TMSSQL;
    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);
    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
  end;

var
  fmMain: TfmMain;

implementation
uses
  Debug
  {$IFDEF VER140}, Variants{$ENDIF};

{$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 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;

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

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

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

const
  Delay = 1000;

procedure TfmMain.Execute;
var
  Data: TdmData;
  ThreadNum: integer;
  i: integer;
begin
  i := CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
  if i <> S_OK then 
    raise Exception.Create('err - ' + IntToStr(i));

  EnterCriticalSection(hCountSec);
    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...');
        MSConnection.Assign(Self.MSConnection);
        MSConnection.LoginPrompt := False;
        MSConnection.Connect;
      Log(IntToStr(ThreadNum) + ' Connected');

      if rgMode.ItemIndex = 0 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 TfmMain.EndExecute(Result: boolean);
begin
  InterlockedDecrement(ThreadCount);
  EnterCriticalSection(hCountSec);
  lbThreadCount.Caption := IntToStr(ThreadCount);
  MessageBeep(1000);
  LeaveCriticalSection(hCountSec);
end;

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

procedure TfmMain.btRunClick(Sender: TObject);
begin
  TestConnected;
  RunThread(Self, @TfmMain.Execute, @TfmMain.EndExecute);
end;

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

procedure TfmMain.btStartClick(Sender: TObject);
begin
  TestConnected;
  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
  MSQuery.Close;
  MSQuery.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.MSSQL.SQL)
  else
    meSQL.Lines.Assign(dmData.MSQuery.SQL)
end;

procedure TfmMain.btDeleteAllClick(Sender: TObject);
begin
  scDeleteAll.Execute;
//  MSConnection.Commit;
end;

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

procedure TfmMain.TestConnected;
begin
  MSConnection.Connect;
  if not MSConnection.Connected then
    Abort;
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.