Chip 2001 December/Chip_2001-12_cd1.bin/zkuste/delphi/kompon/d23456/BKQUERY.ZIP/uBkQuery.pas

Pascal/Delphi Source File | 2001-10-02 | 16.6 KB | 570 lines

(*******************************************************************************
    BkQuery - Backgroud Query
    BkQuery:= EQuery + Backgroud Query = Wait Query + Parse Query + Backgroud Query

    Author: J. Tungli, T-SOFT (c) 2001  mailto:[e-mail]

 *******************************************************************************

  BkCommands:   ( BkOpen, BkExecSQL, BkLocate, BkFindFirst, BkLast, ... )
      if BkQueryTread is not created, BkCommand automatically create
      new BkQueryThread. When a BkCommand is ready call OnBkReady event.

  OnBkReady event:
      Procedure OnBkReady(Sender: TObject; Msg:String; AResult:integer) of object;
      Msg    : result message text (coresponding with ReadyMsg property)
      AResult: result executed result value (1=true 0=false,
                    (coresponding with ReadyResult property)

  BkQueryThread:
      create BkCommands front in thread : ... ->  BkCommand2 -> BkCommand1
      and provide for first command must finish first

  BkStop command:
      wait for BkCommands front finish and dispose BkQueryThread

  BkTerminate command:
      dispose BkQueryThread immediatelly, dont wait for BkCommands front finish

  Example:
      BkQuery1.Database_AliasName:='DBDEMOS';
      BkQuery1.sql.text:='select * from Country';
      BkQuery1.DisableControls;
      BkQuery1.BkOpen;
      BkQuery1.BkLocate('Name','Venez',[loPartialkey]);
      ...
      BkQuery1.BkStop;
      BkQuery1.EnableControls;

********************************************************************************)

unit uBkQuery;

interface

uses
  Windows, Messages, SysUtils, Classes, DB, DBTables,Forms,Controls,stdctrls,Dialogs,uEQuery;

const
   UM_BkReady=WM_User+191;
type
  TOnBkReady = procedure (Sender: TObject; Msg:String; AResult:integer) of object;

  TBkWC=class(TStaticText)
  private
    fMaster:TComponent;
  protected
    procedure UM_BkReady(var AMessage : TMessage); message UM_BkReady;
    { Protected declarations }
  public
  published
  end;

  TBkQuery = class(TEQuery)
  private
    fThreadRun:boolean;
    fThread: TThread;
    fIndex:integer;
    fWC:TBkWC;
    fRes:integer;
    fMsg: string;
    fSession:TSession;
    fDatabase:TDatabase;
    fDBParams:TStringList;
    fDBAlias:string;
    fDBDriver:string;
    fOnBkReady:TOnBkReady;
    procedure SetfIndex(A:integer);
    procedure SetfRes(A:integer);
    procedure SetfMsg(A:string);
    procedure BkInit;
     {Private declarations }
  protected
    { Protected declarations }
  public
    constructor Create(AOwner: TComponent);override;
    destructor Destroy; override;
      { Public declarations }
  published
     property BkExecuteIndex:integer read fIndex write SetfIndex; {read only}
     property ReadyResult: integer read fRes write SetfRes; {read only 1=true 0=false}
     property ReadyMsg:string read fMsg write SetfMsg; {read only}
     property Database_AliasName:string read fDBAlias write fDBAlias;
     property Database_DriverName:string read fDBDriver write fDBDriver;
     property Database_Params:TStringList read fDBParams write fDBParams;
     property OnBkReady : TOnBkReady read fOnBkReady write fOnBkReady;
     procedure BkOpen;
     procedure BkExecSQL(ATransaction:boolean=false; ARollBack:boolean=true);
     procedure BkPost;
     procedure BkApplyUpdates;
     procedure BkMoveBy(AMove:integer);
     procedure BkFirst;
     procedure BkLast;
     procedure BkNext;
     procedure BkPrior;
     procedure BkLocate(const AKeyFields: String; const AKeyValues: Variant; AOptions: TLocateOptions);
     procedure BkFindFirst;
     procedure BkFindLast;
     procedure BkFindNext;
     procedure BkFindPrior;
     procedure BkGotoBookMark(ABookMark:TBookMark);
     procedure BkFetchAll;
     procedure BkCommitUpdates;
     procedure BkRecordCount;
     procedure BkDisableControls;
     procedure BkEnableControls;
     procedure BkStop;
     procedure BkTerminate;
    { Published declarations }
  end;

procedure Register;

implementation

type
  TQueryThread = class(TThread)
  private
    fExit       : boolean;
    fMessageText: string;
    fTrans,fRollBack : boolean;
    fAction     : byte;
    fKeyFields  : string;
    fKeyValues  : variant;
    fOptions    : TLocateOptions;
    fMove       : integer;
    fBookMark   : TBookMark;

    fBkQuery    : TBkQuery;
    fResult     : integer;
    //procedure QueryReady;
    { Private declarations }
  protected
    procedure Execute; override;
    procedure Start( ABkQuery:TBkQuery;AAction:byte;
                     ATransaction,ARollBack:boolean;
                     AKeyFields  : string;
                     AKeyValues  : variant;
                     AOptions    : TLocateOptions;
                     AMove       : integer;
                     ABookMark   : TBookMark);
    procedure Stop(ABkQuery:TBkQuery);
    { Protected declarations }
  public
    constructor Create;
    destructor Destroy; override;
      { Public declarations }
  published
    { Published declarations }
  end;

var
  gIndex:integer;

constructor TBkQuery.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fWC:=nil;fSession:=nil; fDatabase:=nil;
  fMsg:=''; fRes:=0; fThread:=nil;
  fDBParams:=TStringList.Create;
end;

destructor TBkQuery.Destroy;
begin
  fDBParams.Free;
  if fSession<>nil then begin fSession.Close; fSession.Free; end;
  if fDatabase<>nil then fDatabase.Free;
  if fThread<>nil then begin
    fThread.Terminate;
    fThread.WaitFor;
  end;
  inherited Destroy;
end;

procedure TQueryThread.Stop(ABkQuery:TBkQuery);
begin
  fBkQuery:=ABkQuery;
  fBkQuery.fThreadRun:=true;
  fExit:=true;
  Resume;
end;

procedure TQueryThread.Start( ABkQuery:TBkQuery;AAction:byte;
                        ATransaction,ARollBack:boolean;
                        AKeyFields  : string;
                        AKeyValues  : variant;
                        AOptions    : TLocateOptions;
                        AMove       : integer;
                        ABookMark   : TBookMark);
begin
  fExit:=false;
  fBkQuery:=ABkQuery;
  fRollBack:=ARollBack;
  fTrans:=ATransaction;
  fAction:=AAction;
  fKeyFields:=AKeyFields;
  fKeyValues:=AKeyValues;
  fOptions:=AOptions;
  fMove:=AMove;
  fBookMark:=ABookMark;
  Resume;
end;

constructor TQueryThread.Create;
begin
  FreeOnTerminate := True;
  inherited Create(true);
end;

destructor TQueryThread.Destroy;
begin
  inherited Destroy;
end;

const
  cTransaction:boolean=false;
  cRollBack:boolean=true;
  cKeyFields:string='';
  cOptions:TLocateOptions=[];
  cMove: integer=0;
  cBookMark:TBookMark=nil;
var
  Guard: Integer;
  Numbers: Integer;
  cKeyValues:Variant;
{ Thread safe increment of Numbers to guarantee the result is unique }

function GetUniqueNumber: Integer;
asm
@@1:    MOV     EDX,1
        XCHG    Guard,EDX
        OR      EDX,EDX
        JNZ     @@2
        MOV     EAX,Numbers
        INC     EAX
        MOV     Numbers,EAX
        MOV     Guard,EDX
        RET

@@2:    PUSH    0
        CALL    Sleep
        JMP     @@1
end;

procedure TBkWC.UM_BkReady(var AMessage : TMessage);
begin
  if fMaster is TbkQuery then
    with TBkQuery(fMaster) do begin
      if Assigned(fOnBkReady) then fOnBkReady(TBkQuery(fMaster),fMsg,fRes);
    end;
end;

procedure TQueryThread.Execute;
    procedure Posted;
    begin
      fBkQuery.fMsg:=fMessageText;
      fBkQuery.fRes:=fResult;
      //if fBkQuery.fIndex=gIndex then fBkQuery.EnableControls;
      if fBkQuery.fWC<>nil then PostMessage(fBkQuery.fWC.Handle,UM_BkReady,0,0);
      fBkQuery.fThreadRun:=false;
      Suspend;
    end;

//var UniqueNumber: Integer;
begin
  while not Terminated do begin
    try
      if fExit then begin fBkQuery.fThreadRun:=false; exit; end;
      //UniqueNumber := GetUniqueNumber;
      with fBkQuery do begin
        if fSession=nil then fSession:=TSession.Create(nil) else begin
          if fAction<=2 then fSession.close;
        end;
        if fDatabase=nil then fDatabase:=TDatabase.Create(nil) else begin
          if fAction<=2 then fDatabase.Connected:=false;
        end;
        if fAction<=2 then begin
          fSession.SessionName :='Session_'+fBkQuery.Name;
          fDatabase.DatabaseName :='Database_'+fBkQuery.Name;
          fDatabase.SessionName := fSession.SessionName;
          fDatabase.LoginPrompt:=false;
          fDataBase.DriverName:=fDBDriver;
          fDatabase.AliasName:=fDBAlias;
          fDatabase.Params.Text:=fDBParams.Text;
          SessionName := fDatabase.SessionName;
          DatabaseName := fDatabase.DatabaseName;
          SessionName := fDatabase.SessionName;
          DatabaseName := fDatabase.DatabaseName;
        end;
        fResult:=1;
        case fAction of
        1:Open;
        2:if fTrans then begin
            fDatabase.StartTransaction;
            ExecSQL;
            fMessageText := 'OK';
            fDatabase.Commit;
            Posted; //Synchronize(QueryReady);
            continue;
          end else begin
            ExecSQL;
          end;
        3: Post;
        4: ApplyUpdates;
        5: fResult:=MoveBy(fMove);
        6: First;
        7: Last;
        8: Next;
        9: Prior;
        10:if Active and Locate(fKeyFields,fKeyValues,fOptions) then fResult:=1 else begin fResult:=0; fMessageText:='Datset is closed'; end;
        11:if Active and FindFirst then fResult:=1 else begin fResult:=0; fMessageText:='Datset is closed'; end;
        12:if Active and FindLast then fResult:=1 else begin fResult:=0; fMessageText:='Datset is closed'; end;
        13:if Active and FindNext then fResult:=1 else begin fResult:=0; fMessageText:='Datset is closed'; end;
        14:if Active and FindPrior then fResult:=1 else begin fResult:=0; fMessageText:='Datset is closed'; end;
        15:GotoBookMark(fBookMark);
        16:FetchAll;
        17:CommitUpdates;
        18:fResult:=RecordCount;
        19:DisableControls;
        20:EnableControls;
        end;
        fMessageText := 'OK';
        Posted;
        continue;
        //QueryReady;
        //Synchronize(QueryReady);
      end;
    except
      on E: Exception do
      begin
        fResult:=0;
        { Display any error we receive on the status line }
        fMessageText := Format('%s: %s.', [E.ClassName, E.Message]);
        if fTrans then begin
          if fRollBack then begin
            fMessageText:=fMessageText+' -> Rollback';
            fBkQuery.fDatabase.Rollback;
          end else begin
            try fBkQuery.fDatabase.Commit; except end;
          end;
        end;
        Posted;//Synchronize(QueryReady);
       end;
    end;
  end;
end;

// -------------------------------

procedure TBkQuery.BkOpen;
begin
  BkInit;
  if (trim(fDbAlias)='') and (DatabaseName<>'') then fDbAlias:=DatabaseName;
  if Active then Close;
  TQueryThread(fThread).Start(Self,1,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkExecSQL(ATransaction:boolean=false;ARollBack:boolean=true);
begin
  BkInit;
  if (trim(fDbAlias)='') and (DatabaseName<>'') then fDbAlias:=DatabaseName;
  if Active then Close;
  TQueryThread(fThread).Start(Self,2,ATransaction,ARollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkPost;
begin
  BkInit;
  TQueryThread(fThread).Start(Self,3,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkApplyUpdates;
begin
  BkInit;
  TQueryThread(fThread).Start(Self,4,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkMoveBy(AMove:integer);
begin
  BkInit;
  TQueryThread(fThread).Start(Self,5,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,AMove,cBookMark);
end;

procedure TbkQuery.BkFirst;
begin
  BkInit;
  TQueryThread(fThread).Start(Self,6,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkLast;
begin
  BkInit;
  TQueryThread(fThread).Start(Self,7,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkNext;
begin
  BkInit;
  TQueryThread(fThread).Start(Self,8,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkPrior;
begin
  BkInit;
  TQueryThread(fThread).Start(Self,9,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkLocate(const AKeyFields: String; const AKeyValues: Variant; AOptions: TLocateOptions);
begin
  BkInit;
  TQueryThread(fThread).Start(Self,10,cTransaction,cRollBack,
                       AKeyFields,AKeyValues,AOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkFindFirst;
begin
  BkInit;
  TQueryThread(fThread).Start(Self,11,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkFindLast;
begin
  BkInit;
  TQueryThread(fThread).Start(Self,12,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkFindNext;
begin
  BkInit;
  TQueryThread(fThread).Start(Self,13,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkFindPrior;
begin
  BkInit;
  TQueryThread(fThread).Start(Self,14,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkGotoBookMark(ABookMark:TBookMark);
begin
  BkInit;
  TQueryThread(fThread).Start(Self,15,cTransaction,cRollBack,
                        cKeyFields,cKeyValues,cOptions,cMove,ABookMark);
end;

procedure TbkQuery.BkFetchAll;
begin
  BkInit;
  TQueryThread(fThread).Start(Self,3,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkCommitUpdates;
begin
  BkInit;
  TQueryThread(fThread).Start(Self,17,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkRecordCount;
begin
  BkInit;
  TQueryThread(fThread).Start(Self,18,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkDisableControls;
begin
  BkInit;
  TQueryThread(fThread).Start(Self,19,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkEnableControls;
begin
  BkInit;
  TQueryThread(fThread).Start(Self,20,cTransaction,cRollBack,
                       cKeyFields,cKeyValues,cOptions,cMove,cBookMark);
end;

procedure TbkQuery.BkStop;
begin
  while gIndex>fIndex do Application.ProcessMessages;
  Application.ProcessMessages;
  while fThreadRun do Application.ProcessMessages;
  if fThread=nil then begin fIndex:=0; gIndex:=0; exit; end;
  TQueryThread(fThread).Stop(Self);
  while fThreadRun do Application.ProcessMessages;
  fThread:=nil;
  fIndex:=0; gIndex:=0;
end;

procedure TbkQuery.BkTerminate;
begin
  if fThread=nil then exit;
  TQueryThread(fThread).Stop(Self);
  Application.ProcessMessages;
  if fThread<>nil then TQueryThread(fThread).Terminate;
  fThreadRun:=false;
  fIndex:=0; gIndex:=0;
  fThread:=nil;
end;

procedure TBkQuery.BkInit;
begin
  gIndex:=fIndex+1;if gIndex=MaxInt then gIndex:=1;
  Application.ProcessMessages;
  while fThreadRun do Application.ProcessMessages;
  if fThread=nil then fThread:=TQueryThread.Create;

  fThreadRun:=true;
  inc(fIndex); if fIndex=MaxInt then fIndex:=1;
  fMsg:=''; fRes:=0;
  if (fWC=nil) then begin
    fWC:=TBkWC.Create(Owner);
    fWC.Width:=0; fWC.Height:=0;
    fWC.Name:=Name+'_WC';
    fWC.Caption:='';
    if Owner is TForm then
      fWC.Parent:=TWinControl(Owner)
      else fWC.Parent:=Screen.ActiveForm;
    fWC.fMaster:=Self;
  end;
end;

procedure TBkQuery.SetfIndex(A:integer);
begin
  if csDesigning in ComponentState then ShowMessage('property is read only');
end;

procedure TBkQuery.SetfRes(A:integer);
begin
  if csDesigning in ComponentState then ShowMessage('property is read only');
end;

procedure TBkQuery.SetfMsg(A:string);
begin
  if csDesigning in ComponentState then ShowMessage('property is read only');
end;


procedure Register;
begin
  RegisterComponents('Samples', [TBkQuery]);
end;

end.