ztransact.pas

控件名称：WINZEOS.ZIP 2002年08月03日 作者：CapellaDevelopment Zeos系列构件套件包含一组可直接存取Linux知名的免费数据库MySQL、Postgre

{********************************************************}
{                                                        }
{                 Zeos Database Objects                  }
{             Abstract Transaction component             }
{                                                        }
{       Copyright (c) 1999-2001 Sergey Seroukhov         }
{    Copyright (c) 1999-2001 Zeos Development Group      }
{                                                        }
{********************************************************}

unit ZTransact;

interface

{$R *.dcr}

uses
  ExtCtrls, SysUtils, DB, Classes, ZToken, ZConnect, ZDirSql, ZSqlTypes, ZSqlScanner;

{$INCLUDE ../Zeos.inc}

type
  { Transact options }
  TZTransactOption = (toHourGlass);
  TZTransactOptions = set of TZTransactOption;
  TZMonitor = class;

  { BatchExecSql event handlers }
  TOnBeforeBatchExec = procedure (Sender: TObject; var Sql: string) of object;
  TOnAfterbatchExec = procedure (Sender: TObject; var Res: Integer) of object;
  TOnBatchError = procedure (Sender: TObject; const E: Exception; var Stop: Boolean) of object; 

  { Abstract transaction component }
  TZTransact = class(TComponent)
  protected
    FConnected: Boolean;
    FAutoCommit: Boolean;
    FAutoRecovery: Boolean;
    FNotifies: TList;
    FOptions: TZTransactOptions;
    FDatabase: TZDatabase;
    FDatabaseType: TDatabaseType;
    FHandle: TDirTransact;
    FQuery: TDirQuery;
    FOnDataChange: TNotifyEvent;
    FOnApplyUpdates: TNotifyEvent;
    FOnCommit: TNotifyEvent;
    FOnRollback: TNotifyEvent;
    FOnBeforeConnect: TNotifyEvent;
    FOnAfterConnect: TNotifyEvent;
    FOnBeforeDisconnect: TNotifyEvent;
    FOnAfterDisconnect: TNotifyEvent;
    FVersion: Integer;
    FBatchCurPos, FBatchCurLen, FBatchCurrentLine: Integer;
    FOnBeforeBatchExec: TOnBeforeBatchExec;
    FOnAfterBatchExec: TOnAfterBatchExec;
    FOnBatchError: TOnBatchError;

    procedure SetConnected(Value: Boolean);
    procedure SetDatabase(Value: TZDatabase);
    function  GetTransactSafe: Boolean;
    procedure SetTransactSafe(Value: Boolean);
    function  GetNotifies(Index: Integer): TObject;
    function  GetNotifyCount: Integer;

    procedure Loaded; override;

    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure DoDataChange(Sql: string);
    procedure DoCommit;
    procedure DoRollback;

    property AutoRecovery: Boolean read FAutoRecovery write FAutoRecovery;
    property DatabaseType: TDatabaseType read FDatabaseType;
    property TransactSafe: Boolean read GetTransactSafe write SetTransactSafe;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure Connect; virtual;
    procedure Disconnect; virtual;
    function ExecSql(Sql: WideString): LongInt; virtual;
    function ExecSqlParams(Sql: WideString; Params: TVarRecArray;
      ParamCount: Integer): LongInt; virtual;
    function BatchExecSql(Sql: WideString): LongInt;
    function ExecFunc(Func: WideString): WideString; virtual;
    procedure Commit; virtual;
    procedure Rollback; virtual;
    procedure Recovery(Force: Boolean); virtual;
    procedure DoApplyUpdates;

    procedure AddMonitor(Monitor: TZMonitor); virtual; abstract;
    procedure DeleteMonitor(Monitor: TZMonitor); virtual; abstract;

    procedure AddNotify(Notify: TObject);
    procedure RemoveNotify(Notify: TObject);
    procedure CloseNotifies;

    property Database: TZDatabase read FDatabase write SetDatabase;
    property Connected: Boolean read FConnected write SetConnected;
    property Handle: TDirTransact read FHandle;
    property QueryHandle: TDirQuery read FQuery;

    property Notifies[Index: Integer]: TObject read GetNotifies;
    property NotifyCount: Integer read GetNotifyCount;
  published
    property Options: TZTransactOptions read FOptions write FOptions;
    property AutoCommit: Boolean read FAutoCommit write FAutoCommit;
    property Version: Integer read FVersion;
    property BatchCurPos: Integer read FBatchCurPos;
    property BatchCurLen: Integer read FBatchCurLen;
    property BatchCurrentLine: Integer read FBatchCurrentLine;

    property OnBeforeConnect: TNotifyEvent read FOnBeforeConnect write FOnBeforeConnect;
    property OnAfterConnect: TNotifyEvent read FOnAfterConnect write FOnAfterConnect;
    property OnBeforeDisconnect: TNotifyEvent read FOnBeforeDisconnect write FOnBeforeDisconnect;
    property OnAfterDisconnect: TNotifyEvent read FOnAfterDisconnect write FOnAfterDisconnect;
    property OnBeforeBatchExec: TOnBeforeBatchExec read FOnBeforeBatchExec write FOnBeforeBatchExec;
    property OnAfterBatchExec: TOnAfterBatchExec read FOnAfterBatchExec write FOnAfterBatchExec;
    property OnBatchError: TOnBatchError read FOnBatchError write FOnBatchError;
    property OnDataChange: TNotifyEvent read FOnDataChange write FOnDataChange;
    property OnApplyUpdates: TNotifyEvent read FOnApplyUpdates write FOnApplyUpdates;
    property OnCommit: TNotifyEvent read FOnCommit write FOnCommit;
    property OnRollback: TNotifyEvent read FOnRollback write FOnRollback;
  end;

  { Event on post sql query }
  TMonitorEvent = procedure(Sql, Result: string) of object;

  { Abstract component for monitoring outgoing queries }
  TZMonitor = class (TComponent)
  private
    FTransact: TZTransact;
    FMonitorEvent: TMonitorEvent;
    procedure SetTransact(const Value: TZTransact);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    destructor Destroy; override;
  published
    property Transaction: TZTransact read FTransact write SetTransact;
    property OnMonitorEvent: TMonitorEvent read FMonitorEvent write FMonitorEvent;
  end;

  { Monitors list class }
  TZMonitorList = class (TList)
  private
    function GetMonitor(Index: Integer): TZMonitor;
  public
    procedure AddMonitor(Value: TZMonitor);
    procedure DeleteMonitor(Value: TZMonitor);
    procedure InvokeEvent(Sql, Result: WideString; Error: Boolean);

    property Monitors[Index: Integer]: TZMonitor read GetMonitor;
  end;

  { Sql statements executing component }
  TZBatchSql = class(TComponent)
  private
    FTransact: TZTransact;
    FAffectedRows: LongInt;
    FBeforeExecute: TNotifyEvent;
    FAfterExecute: TNotifyEvent;
    FSql: TStringList;

    procedure SetSql(Value: TStringList);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;

    procedure ExecSql;
  published
    property Transaction: TZTransact read FTransact write FTransact;
    property Sql: TStringList read FSql write SetSql;
    property RowsAffected: LongInt read FAffectedRows;

    property OnBeforeExecute: TNotifyEvent read FBeforeExecute write FBeforeExecute;
    property OnAfterExecute: TNotifyEvent read FAfterExecute write FAfterExecute;
  end;

  { Custom Notify event handler type }
  TZNotifyEvent = procedure (Sender: TObject; Event: string) of object;

  { Asynchronous notifying}
  TZNotify = class (TComponent)
  private
    FActive: Boolean;
    FAutoOpen: Boolean;
    FEventsList: TStringList;
    FTimer: TTimer;
    FFirstConnect: Boolean;

    FBeforeRegister: TZNotifyEvent;
    FBeforeUnregister: TZNotifyEvent;
    FAfterRegister: TZNotifyEvent;
    FAfterUnregister: TZNotifyEvent;
    FNotifyFired: TZNotifyEvent;
  protected
    FTransact: TZTransact;
    FHandle: TDirNotify;
    FBackEventsList: TStringList;

    procedure SetActive(Value: Boolean);
    function GetInterval: Cardinal; virtual;
    procedure SetInterval(Value: Cardinal); virtual;
    procedure SetEventsList(Value: TStringList); virtual;
    procedure SetTransact(Value: TZTransact);

    procedure TimerProc(Sender: TObject); virtual;
    procedure CheckEvents; virtual;
    procedure EventsChange(Sender: TObject); virtual;
    procedure EventsChanging(Sender: TObject); virtual;
    procedure CheckActive; virtual;

  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure Open; virtual;
    procedure Close; virtual;

    procedure ListenTo(Event: string);
    procedure DoNotify(Event: string);
    procedure UnlistenTo(Event: string);

    property Handle: TDirNotify read FHandle;
  published

    property Active: Boolean read FActive write SetActive;
    property EventsList: TStringList read FEventsList write SetEventsList;
    property Interval: Cardinal read GetInterval write SetInterval;

    property OnBeforeRegister: TZNotifyEvent read FBeforeRegister write FBeforeRegister;
    property OnAfterRegister: TZNotifyEvent read FAfterRegister write FAfterRegister;
    property OnBeforeUnregister: TZNotifyEvent read FBeforeUnregister write FBeforeUnregister;
    property OnAfterUnregister: TZNotifyEvent read FAfterUnregister write FAfterUnregister;
    property OnNotify: TZNotifyEvent read FNotifyFired write FNotifyFired;
  end;

  { Custom TThread descendent to allow true asynchronous notify processing }
implementation

uses ZDbaseConst, ZConvert, ZSqlScript
{$IFNDEF NO_GUI}{$IFNDEF LINUX}
  ,Windows, Controls, Forms
{$ELSE}
  ,QControls, QForms
{$ENDIF}{$ENDIF};

{***************** TZTransact implementation *****************}

{ Class constructor }
constructor TZTransact.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FConnected  := False;
  FAutoCommit := True;
  FOptions := [toHourGlass];
  FVersion := ZDBO_VERSION;
  FNotifies := TList.Create;
  FDatabaseType := dtUnknown;
end;

{ Class destructor }
destructor TZTransact.Destroy;
begin
  if Connected then
    Disconnect;
  CloseNotifies;
  
  if Assigned(FDatabase) then
    FDatabase.RemoveTransaction(Self);
  FQuery.Free;
  FHandle.Free;
  FNotifies.Free;
  inherited Destroy;
end;

{ Set connected prop }
procedure TZTransact.SetConnected(Value: Boolean);
begin
  if Value <> FConnected then
    if Value then Connect
    else Disconnect;
end;

{ Set database connection prop }
procedure TZTransact.SetDatabase(Value: TZDatabase);
begin
  Disconnect;
  try
    if Assigned(FDatabase) then
      FDatabase.RemoveTransaction(Self);
    if Assigned(Value) then
      Value.AddTransaction(Self);
  finally
    FDatabase := Value;
    if Assigned(FDatabase) then
    begin
      FHandle.Connect := FDatabase.Handle;
      FQuery.Connect := FDatabase.Handle;
    end
    else
    begin
      FHandle.Connect := nil;
      FQuery.Connect := nil;
    end;
  end;
end;

{ Get transaction safe property }
function TZTransact.GetTransactSafe: Boolean;
begin
  Result := Handle.TransactSafe;
end;

{ Set transaction safe property}
procedure TZTransact.SetTransactSafe(Value: Boolean);
begin
  if Handle.TransactSafe <> Value then
  begin
    if Connected then
    begin
      if Handle.TransactSafe then
        Handle.EndTransaction
      else
        Handle.StartTransaction;
    end;
    Handle.TransactSafe := Value;
  end;
end;

{ Process notification method }
procedure TZTransact.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (AComponent = FDatabase ) and (Operation = opRemove) then
  begin
    Disconnect;
    FDatabase := nil;
    FHandle.Connect := nil;
    FQuery.Connect := nil;
  end;
end;

{ Connect to Sql-database }
procedure TZTransact.Connect;
{$IFNDEF NO_GUI}
var
  OldCursor: TCursor;
{$ENDIF}
begin
  if FConnected then Exit;
{$IFNDEF NO_GUI}
  OldCursor := Screen.Cursor;
{$ENDIF}
  try
{$IFNDEF NO_GUI}
    if toHourGlass in FOptions then
      Screen.Cursor := crSqlWait;
{$ENDIF}

    if not Assigned(FDatabase) then
      DatabaseError(SConnectNotDefined);

    if Assigned(OnBeforeConnect) then
      OnBeforeConnect(Self);
    FDatabase.Connect;
    if not FDatabase.Connected then
      DatabaseError(SConnectError);

    if not FHandle.Active then
    begin
      FHandle.Open;
      if FHandle.Status <> csOk then
        DatabaseError(Convert(FHandle.Error, FDatabase.Encoding, etNone));
    end;
    FConnected := FHandle.Active;
    if Assigned(OnAfterConnect) then
      OnAfterConnect(Self);
  finally
{$IFNDEF NO_GUI}
    Screen.Cursor := OldCursor;
{$ENDIF}
  end;
end;

{ Disconnect from database }
procedure TZTransact.Disconnect;
{$IFNDEF NO_GUI}
var
  OldCursor: TCursor;
{$ENDIF}
begin
  if not FConnected then Exit;
{$IFNDEF NO_GUI}
  OldCursor := Screen.Cursor;
{$ENDIF}
  try
{$IFNDEF NO_GUI}
    if toHourGlass in FOptions then
      Screen.Cursor := crSqlWait;
{$ENDIF}

    //CloseNotifies;
    if Assigned(OnBeforeDisconnect) then
      OnBeforeDisconnect(Self);
    FConnected := False;

    FHandle.Close;
    if FHandle.Status <> csOk then
      DatabaseError(Convert(FHandle.Error, FDatabase.Encoding, etNone));
  finally
{$IFNDEF NO_GUI}
    Screen.Cursor := OldCursor;
{$ENDIF}
  end;
  if Assigned(OnAfterDisconnect) then
    OnAfterDisconnect(Self);
end;

{ Call OnDataChange event }
procedure TZTransact.DoDataChange(Sql: string);
var
  Token: string;
begin
  if Assigned(FOnDataChange) then
  begin
    Token := UpperCase(StrTok(Sql,' '#9#10#13));
    if (Token = 'UPDATE') or (Token = 'INSERT') or (Token = 'DELETE') then
      FOnDataChange(Self);
  end;
end;

{ Invoke OnApplyUpdates event }
procedure TZTransact.DoApplyUpdates;
begin
  if Assigned(FOnApplyUpdates) then
    FOnApplyUpdates(Self);
end;

{ Invoke OnCommit event }
procedure TZTransact.DoCommit;
begin
  if Assigned(FOnCommit) then
    FOnCommit(Self);
end;

{ Invoke OnRollback event }
procedure TZTransact.DoRollback;
begin
  if Assigned(FOnRollback) then
    FOnRollback(Self);
end;

{ Execute a query }
function TZTransact.ExecSql(Sql: WideString): LongInt;
var
{$IFNDEF NO_GUI}
  OldCursor: TCursor;
{$ENDIF}
  Error: string;
begin
  if not FConnected then
    DatabaseError(SNotConnected);
{$IFNDEF NO_GUI}
  OldCursor := Screen.Cursor;
{$ENDIF}
  try
{$IFNDEF NO_GUI}
    if toHourGlass in FOptions then
      Screen.Cursor := crSqlWait;
{$ENDIF}

    FQuery.Sql := Sql;
    Result := FQuery.Execute;
    if FQuery.Status <> qsCommandOk then
    begin
      Error := Convert(FQuery.Error, FDatabase.Encoding, etNone);
      Recovery(False);
      DatabaseError(Error);
    end else
      DoDataChange(Sql);

    if FAutoCommit then Commit;
  finally
    FQuery.Sql := '';
{$IFNDEF NO_GUI}
    Screen.Cursor := OldCursor;
{$ENDIF}
  end;
end;

{ Execute an sql statement with parameters }
function TZTransact.ExecSqlParams(Sql: WideString; Params: TVarRecArray;
  ParamCount: Integer): LongInt;
var
{$IFNDEF NO_GUI}
  OldCursor: TCursor;
{$ENDIF}
  Error: string;
begin
  if not FConnected then
    DatabaseError(SNotConnected);
{$IFNDEF NO_GUI}
  OldCursor := Screen.Cursor;
{$ENDIF}
  try
{$IFNDEF NO_GUI}
    if toHourGlass in FOptions then
      Screen.Cursor := crSqlWait;
{$ENDIF}

    FQuery.Sql := Sql;
    Result := FQuery.ExecuteParams(Params, ParamCount);
    if FQuery.Status <> qsCommandOk then
    begin
      Error := Convert(FQuery.Error, FDatabase.Encoding, etNone);
      Recovery(False);
      DatabaseError(Error);
    end else
      DoDataChange(Sql);

    if FAutoCommit then Commit;
  finally
{$IFNDEF NO_GUI}
    Screen.Cursor := OldCursor;
{$ENDIF}
  end;
end;

{ Execute a function with params and return a result }
function TZTransact.ExecFunc(Func: WideString): WideString;
var
{$IFNDEF NO_GUI}
  OldCursor: TCursor;
{$ENDIF}
  Error: string;
begin
  if not FConnected then
    DatabaseError(SNotConnected);
{$IFNDEF NO_GUI}
  OldCursor := Screen.Cursor;
{$ENDIF}
  try
{$IFNDEF NO_GUI}
    if toHourGlass in FOptions then
      Screen.Cursor := crSqlWait;
{$ENDIF}

    FQuery.Sql := 'SELECT '+Func;
    FQuery.Open;
    if FQuery.Status <> qsTuplesOk then
    begin
      Error := Convert(FQuery.Error, FDatabase.Encoding, etNone);
      Recovery(False);
      DatabaseError(Error);
    end;

    Result := FQuery.Field(0);
    FQuery.Close;
    if FAutoCommit then Commit;
  finally
{$IFNDEF NO_GUI}
    Screen.Cursor := OldCursor;
{$ENDIF}
  end;
end;

{ Commit transaction }
procedure TZTransact.Commit;
{$IFNDEF NO_GUI}
var
  OldCursor: TCursor;
{$ENDIF}
begin
  if not FConnected then
    DatabaseError(SNotConnected);