rxquery.pas

灰鸽子1.23源码,,,,,,,

{*******************************************************}
{                                                       }
{         Delphi VCL Extensions (RX)                    }
{                                                       }
{         Copyright (c) 2001,2002 SGB Software          }
{         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
{                        Igor Pavluk and Serge Korolev  }
{                                                       }
{*******************************************************}

unit RxQuery;

{$I RX.INC}
{$P+,W-,R-}

interface

uses Bde, Windows, RTLConsts,  Classes, SysUtils, DB, DBTables, rxStrUtils, BdeUtils;

{.$DEFINE DEBUG}

const
  DefaultMacroChar = '%';
  DefaultTermChar  = '/';

{ TRxQuery }

type
  TQueryOpenStatus = (qsOpened, qsExecuted, qsFailed);

  TRxQuery = class(TQuery)
  private
    FDisconnectExpected: Boolean;
    FSaveQueryChanged: TNotifyEvent;
    FMacroChar: Char;
    FMacros: TParams;
    FSQLPattern: TStrings;
    FStreamPatternChanged: Boolean;
    FPatternChanged: Boolean;
    FOpenStatus: TQueryOpenStatus;
{$IFNDEF WIN32}
    FParamCheck: Boolean;
{$ENDIF}
    function GetMacros: TParams;
    procedure SetMacros(Value: TParams);
    procedure SetSQL(Value: TStrings);
    procedure PatternChanged(Sender: TObject);
    procedure QueryChanged(Sender: TObject);
    procedure RecreateMacros;
    procedure CreateMacros(List: TParams; const Value: PChar);
    procedure Expand(Query: TStrings);
    function GetMacroCount: Word;
    procedure SetMacroChar(Value: Char);
    function GetRealSQL: TStrings;
{$IFDEF DEBUG}
    procedure SetRealSQL(Value: TStrings);
{$ENDIF DEBUG}
  protected
{$IFDEF RX_D3}
    procedure InternalFirst; override;
    function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
{$ENDIF}
    procedure Loaded; override;
    function CreateHandle: HDBICur; override;
    procedure OpenCursor {$IFDEF RX_D3} (InfoQuery: Boolean) {$ENDIF}; override;
    procedure Disconnect; override;
{$IFDEF RX_D5}
  protected
    { IProviderSupport }
    procedure PSExecute; override;
    function PSGetDefaultOrder: TIndexDef; override;
    function PSGetTableName: string; override;
{$ENDIF}
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ExpandMacros;
    procedure ExecSQL;
    procedure Prepare;
    procedure OpenOrExec(ChangeLive: Boolean);
    procedure ExecDirect;
    function MacroByName(const Value: string): TParam;
{$IFNDEF RX_D3}
    function IsEmpty: Boolean;
{$ENDIF RX_D3}
    property MacroCount: Word read GetMacroCount;
    property OpenStatus: TQueryOpenStatus read FOpenStatus;
{$IFNDEF DEBUG}
    property RealSQL: TStrings read GetRealSQL;
{$ENDIF DEBUG}
  published
{$IFNDEF WIN32}
    property ParamCheck: Boolean read FParamCheck write FParamCheck default True;
{$ENDIF}
    property MacroChar: Char read FMacroChar write SetMacroChar default DefaultMacroChar;
    property SQL: TStrings read FSQLPattern write SetSQL;
{$IFDEF DEBUG}
    property RealSQL: TStrings read GetRealSQL write SetRealSQL stored False;
{$ENDIF DEBUG}
    property Macros: TParams read GetMacros write SetMacros;
  end;

{$IFDEF WIN32}

{ TRxQueryThread }

  TRunQueryMode = (rqOpen, rqExecute, rqExecDirect, rqOpenOrExec);

  TRxQueryThread = class(TThread)
  private
    FData: TBDEDataSet;
    FMode: TRunQueryMode;
    FPrepare: Boolean;
    FException: TObject;
    procedure DoHandleException;
  protected
    procedure ModeError; virtual;
    procedure DoTerminate; override;
    procedure Execute; override;
    procedure HandleException; virtual;
  public
    constructor Create(Data: TBDEDataSet; RunMode: TRunQueryMode;
      Prepare, CreateSuspended: Boolean);
  end;

{$ENDIF WIN32}

{ TSQLScript }

  TScriptAction = (saFail, saAbort, saRetry, saIgnore, saContinue);

  TScriptErrorEvent = procedure(Sender: TObject; E: EDatabaseError;
    LineNo, StatementNo: Integer; var Action: TScriptAction) of object;

  TSQLScript = class(TComponent)
  private
    FSQL: TStrings;
    FParams: TParams;
    FQuery: TRxQuery;
    FTransaction: Boolean;
    FSemicolonTerm: Boolean;
    FIgnoreParams: Boolean;
    FTerm: Char;
    FBeforeExec: TNotifyEvent;
    FAfterExec: TNotifyEvent;
    FOnScriptError: TScriptErrorEvent;
{$IFDEF WIN32}
    function GetSessionName: string;
    procedure SetSessionName(const Value: string);
    function GetDBSession: TSession;
    function GetText: string;
{$ENDIF WIN32}
{$IFDEF RX_D4}
    procedure ReadParamData(Reader: TReader);
    procedure WriteParamData(Writer: TWriter);
{$ENDIF RX_D4}
    function GetDatabase: TDatabase;
    function GetDatabaseName: string;
    procedure SetDatabaseName(const Value: string);
    procedure CreateParams(List: TParams; const Value: PChar);
    procedure QueryChanged(Sender: TObject);
    procedure SetQuery(Value: TStrings);
    procedure SetParamsList(Value: TParams);
    function GetParamsCount: Cardinal;
  protected
{$IFDEF RX_D4}
    procedure DefineProperties(Filer: TFiler); override;
{$ENDIF RX_D4}
    procedure CheckExecQuery(LineNo, StatementNo: Integer);
    procedure ExecuteScript(StatementNo: Integer); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ExecSQL;
    procedure ExecStatement(StatementNo: Integer);
    function ParamByName(const Value: string): TParam;
{$IFDEF WIN32}
    property DBSession: TSession read GetDBSession;
    property Text: string read GetText;
{$ELSE}
    function GetText: PChar;
{$ENDIF WIN32}
    property Database: TDatabase read GetDatabase;
    property ParamCount: Cardinal read GetParamsCount;
  published
    property DatabaseName: string read GetDatabaseName write SetDatabaseName;
    property IgnoreParams: Boolean read FIgnoreParams write FIgnoreParams default False;
    property SemicolonTerm: Boolean read FSemicolonTerm write FSemicolonTerm default True;
{$IFDEF WIN32}
    property SessionName: string read GetSessionName write SetSessionName;
{$ENDIF WIN32}
    property Term: Char read FTerm write FTerm default DefaultTermChar;
    property SQL: TStrings read FSQL write SetQuery;
    property Params: TParams read FParams write SetParamsList {$IFDEF RX_D4} stored False {$ENDIF};
    property Transaction: Boolean read FTransaction write FTransaction;
    property BeforeExec: TNotifyEvent read FBeforeExec write FBeforeExec;
    property AfterExec: TNotifyEvent read FAfterExec write FAfterExec;
    property OnScriptError: TScriptErrorEvent read FOnScriptError write FOnScriptError;
  end;

const
  dbfExecScript = dbfTable;

procedure CreateQueryParams(List: TParams; const Value: PChar; Macro: Boolean;
  SpecialChar: Char; Delims: TCharSet);

implementation

uses DBUtils, Consts, DBConsts, Forms {$IFDEF RX_D3}, BDEConst {$ENDIF}
  {$IFNDEF WIN32}, Str16 {$ENDIF}, VclUtils;

{ Parse SQL utility routines }

function NameDelimiter(C: Char; Delims: TCharSet): Boolean;
begin
  Result := (C in [' ', ',', ';', ')', #13, #10]) or (C in Delims);
end;

function IsLiteral(C: Char): Boolean;
begin
  Result := C in ['''', '"'];
end;

procedure CreateQueryParams(List: TParams; const Value: PChar; Macro: Boolean;
  SpecialChar: Char; Delims: TCharSet);
var
  CurPos, StartPos: PChar;
  CurChar: Char;
  Literal: Boolean;
  EmbeddedLiteral: Boolean;
  Name: string;

  function StripLiterals(Buffer: PChar): string;
  var
    Len: Word;
    TempBuf: PChar;

    procedure StripChar(Value: Char);
    begin
      if TempBuf^ = Value then
        StrMove(TempBuf, TempBuf + 1, Len - 1);
      if TempBuf[StrLen(TempBuf) - 1] = Value then
        TempBuf[StrLen(TempBuf) - 1] := #0;
    end;

  begin
    Len := StrLen(Buffer) + 1;
    TempBuf := AllocMem(Len);
    Result := '';
    try
      StrCopy(TempBuf, Buffer);
      StripChar('''');
      StripChar('"');
      Result := StrPas(TempBuf);
    finally
      FreeMem(TempBuf, Len);
    end;
  end;

begin
  if SpecialChar = #0 then Exit;
  CurPos := Value;
  Literal := False;
  EmbeddedLiteral := False;
  repeat
    CurChar := CurPos^;
    if (CurChar = SpecialChar) and not Literal and ((CurPos + 1)^ <> SpecialChar) then
    begin
      StartPos := CurPos;
      while (CurChar <> #0) and (Literal or not NameDelimiter(CurChar, Delims)) do begin
        Inc(CurPos);
        CurChar := CurPos^;
        if IsLiteral(CurChar) then begin
          Literal := Literal xor True;
          if CurPos = StartPos + 1 then EmbeddedLiteral := True;
        end;
      end;
      CurPos^ := #0;
      if EmbeddedLiteral then begin
        Name := StripLiterals(StartPos + 1);
        EmbeddedLiteral := False;
      end
      else Name := StrPas(StartPos + 1);
      if Assigned(List) then begin
{$IFDEF RX_D4}
        if List.FindParam(Name) = nil then begin
{$ENDIF RX_D4}
          if Macro then
            List.CreateParam(ftString, Name, ptInput).AsString := TrueExpr
          else List.CreateParam(ftUnknown, Name, ptUnknown);
{$IFDEF RX_D4}
        end;
{$ENDIF RX_D4}
      end;
      CurPos^ := CurChar;
      StartPos^ := '?';
      Inc(StartPos);
      StrMove(StartPos, CurPos, StrLen(CurPos) + 1);
      CurPos := StartPos;
    end
    else if (CurChar = SpecialChar) and not Literal and ((CurPos + 1)^ = SpecialChar) then
      StrMove(CurPos, CurPos + 1, StrLen(CurPos) + 1)
    else if IsLiteral(CurChar) then Literal := Literal xor True;
    Inc(CurPos);
  until CurChar = #0;
end;

{ TRxQuery }

constructor TRxQuery.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
{$IFNDEF WIN32}
  FParamCheck := True;
{$ENDIF WIN32}
  FOpenStatus := qsFailed;
  FSaveQueryChanged := TStringList(inherited SQL).OnChange;
  TStringList(inherited SQL).OnChange := QueryChanged;
  FMacroChar := DefaultMacroChar;
  FSQLPattern := TStringList.Create;
  TStringList(SQL).OnChange := PatternChanged;
  FMacros := TParams.Create{$IFDEF RX_D4}(Self){$ENDIF};
end;

destructor TRxQuery.Destroy;
begin
  Destroying;
  Disconnect;
  FMacros.Free;
  FSQLPattern.Free;
  inherited Destroy;
end;

procedure TRxQuery.Loaded;
begin
  inherited Loaded;
  GetMacros; {!! trying this way}
end;

{$IFDEF RX_D3}

procedure TRxQuery.InternalFirst;
begin
  if not (UniDirectional and BOF) then
    inherited InternalFirst;
end;

function TRxQuery.GetRecord(Buffer: PChar; GetMode: TGetMode;
  DoCheck: Boolean): TGetResult;
begin
  //!!!!!!
  if UniDirectional and (GetMode in [gmPrior, gmNext]) then DoCheck := False;
  Result := inherited GetRecord(Buffer, GetMode, DoCheck);
end;

{$ENDIF}

function TRxQuery.CreateHandle: HDBICur;
begin
  FOpenStatus := qsFailed;
  Result := inherited CreateHandle;
  if Result = nil then FOpenStatus := qsExecuted
  else FOpenStatus := qsOpened;
end;

procedure TRxQuery.OpenCursor;
begin
  ExpandMacros;
  inherited OpenCursor{$IFDEF RX_D3}(InfoQuery){$ENDIF};
end;

procedure TRxQuery.ExecSQL;
begin
  ExpandMacros;
  inherited ExecSQL;
end;

procedure TRxQuery.Prepare;
begin
  ExpandMacros;
  inherited Prepare;
end;

procedure TRxQuery.OpenOrExec(ChangeLive: Boolean);

  procedure TryOpen;
  begin
    try
      Open;
    except
      if OpenStatus <> qsExecuted then raise;
    end;
  end;

begin
  try
    TryOpen;
  except
    on E: EDatabaseError do
      if RequestLive and ChangeLive then begin
        RequestLive := False;
        try
          TryOpen;
        except
          on E: EDatabaseError do
            if OpenStatus <> qsOpened then
              ExecDirect
            else begin
              FOpenStatus := qsFailed;
              raise;
            end;
          else raise;
        end;
      end
      else begin
        if OpenStatus <> qsOpened then
          ExecDirect
        else begin
          FOpenStatus := qsFailed;
          raise;
        end;
      end;
    else raise;
  end;
end;

procedure TRxQuery.ExecDirect;
{$IFNDEF WIN32}
var
  P: PChar;
{$ENDIF}
begin
  CheckInactive;
  SetDBFlag(dbfExecSQL, True);
  try
    if SQL.Count > 0 then begin
      FOpenStatus := qsFailed;
{$IFDEF WIN32}
      Check(DbiQExecDirect(DBHandle, qryLangSQL, PChar(inherited SQL.Text),
        nil));
{$ELSE}
      P := inherited SQL.GetText;
      try
        Check(DbiQExecDirect(DBHandle, qryLangSQL, P, nil));
      finally
        StrDispose(P);
      end;
{$ENDIF WIN32}
      FOpenStatus := qsExecuted;
    end
    else _DBError(SEmptySQLStatement);
  finally
    SetDBFlag(dbfExecSQL, False);
  end;
end;

procedure TRxQuery.Disconnect;
var
  Strings: TStrings;
  Event1, Event2: TNotifyEvent;
begin
  inherited Disconnect;
  if (csDestroying in ComponentState) then Exit;
  Strings := inherited SQL;
  Event1 := TStringList(Strings).OnChange;
  Event2 := QueryChanged;
  if @Event1 <> @Event2 then begin
    if not FDisconnectExpected then SQL := inherited SQL;
    TStringList(inherited SQL).OnChange := QueryChanged;
  end;
end;

procedure TRxQuery.SetMacroChar(Value: Char);
begin
  if Value <> FMacroChar then begin
    FMacroChar := Value;
    RecreateMacros;
  end;
end;

function TRxQuery.GetMacros: TParams;
begin
  if FStreamPatternChanged then begin
    FStreamPatternChanged := False;
    PatternChanged(nil);
  end;
  Result := FMacros;
end;

procedure TRxQuery.SetMacros(Value: TParams);
begin
  FMacros.AssignValues(Value);
end;

procedure TRxQuery.SetSQL(Value: TStrings);
begin
  inherited Disconnect;
  TStringList(FSQLPattern).OnChange := nil;
  FSQLPattern.Assign(Value);
  TStringList(FSQLPattern).OnChange := PatternChanged;
  PatternChanged(nil);
end;

procedure TRxQuery.PatternChanged(Sender: TObject);
begin
  if (csLoading in ComponentState) then begin
    FStreamPatternChanged := True;
    Exit;
  end;
  inherited Disconnect;
  RecreateMacros;
  FPatternChanged := True;
  try
    ExpandMacros;
  finally
    FPatternChanged := False;
  end;
end;

procedure TRxQuery.QueryChanged(Sender: TObject);
{$IFNDEF WIN32}
var
  List: TParams;
  SaveParams: Boolean;
{$ENDIF}
begin
{$IFDEF WIN32}
  FSaveQueryChanged(Sender);
{$ELSE}
  SaveParams := not (ParamCheck or (csDesigning in ComponentState));
  if SaveParams then List := TParams.Create{$IFDEF RX_D4}(Self){$ENDIF};
  try
    if SaveParams then List.Assign(Params);
    FSaveQueryChanged(Sender);
    if SaveParams then Params.Assign(List);
  finally
    if SaveParams then List.Free;
  end;
{$ENDIF WIN32}
  if not FDisconnectExpected then begin