{*******************************************************}
{                                                       }
{         Delphi VCL Extensions (RX)                    }
{                                                       }
{         Copyright (c) 1995, 1996 AO ROSNO             }
{         Copyright (c) 1997, 1998 Master-Bank          }
{                                                       }
{*******************************************************}

unit DBQBE;

{*************************************************************************}
{ The Delphi TQBEQuery component.                                         }
{ This component derives from TDBDataSet and is much like TQuery except   }
{ the language used for Query is QBE (Query by example).                  }
{ You can create the QBE queries from Paradox or DatabaseDesktop and then }
{ load or paste the query strings in the QBE property of TQBEQuery.       }
{*************************************************************************}

{$I RX.INC}
{$N+,P+,S-}

interface

uses SysUtils, {$IFDEF WIN32} Windows, Bde, {$ELSE} WinTypes, WinProcs,
  DbiErrs, DbiTypes, DbiProcs, {$ENDIF} Classes, Controls, DB, DBTables;

const
  DefQBEStartParam = '#';

type
  TCheckType = (ctNone, ctCheck, ctCheckPlus, ctCheckDesc, ctCheckGroup);

{ TQBEQuery }

  TQBEQuery = class(TDBDataSet)
  private
    FStmtHandle: HDBIStmt;
    FQBE: TStrings;
    FPrepared: Boolean;
    FParams: TParams;
    FStartParam: Char;
    FAuxiliaryTables: Boolean;
{$IFDEF WIN32}
    FText: string;
    FRowsAffected: Integer;
{$ELSE}
    FText: PChar;
{$ENDIF}
{$IFDEF RX_D3}
    FConstrained: Boolean;
{$ENDIF}
    FLocal: Boolean;
    FRequestLive: Boolean;
    FBlankAsZero: Boolean;
    FParamCheck: Boolean;
    function CreateCursor(GenHandle: Boolean): HDBICur;
    procedure ReplaceParams(QBEText: TStrings);
    procedure CreateParams(List: TParams; const Value: PChar);
    procedure FreeStatement;
    function GetQueryCursor(GenHandle: Boolean): HDBICur;
    procedure GetStatementHandle(QBEText: PChar);
    procedure PrepareQBE(Value: PChar);
    procedure QueryChanged(Sender: TObject);
    procedure SetQuery(Value: TStrings);
    procedure SetParamsList(Value: TParams);
    procedure SetPrepared(Value: Boolean);
    procedure SetPrepare(Value: Boolean);
    procedure SetStartParam(Value: Char);
{$IFDEF RX_D4}
    procedure ReadParamData(Reader: TReader);
    procedure WriteParamData(Writer: TWriter);
{$ENDIF}
{$IFDEF WIN32}
    function GetRowsAffected: Integer;
{$ENDIF}
{$IFDEF RX_D5}
  protected
    { IProviderSupport }
    procedure PSExecute; override;
    function PSGetParams: TParams; override;
    procedure PSSetCommandText(const CommandText: string); override;
    procedure PSSetParams(AParams: TParams); override;
{$ENDIF}
  protected
    function CreateHandle: HDBICur; override;
    procedure Disconnect; override;
    function GetParamsCount: Word;
{$IFDEF RX_D4}
    procedure DefineProperties(Filer: TFiler); override;
{$ENDIF}
{$IFDEF RX_V110}
    function SetDBFlag(Flag: Integer; Value: Boolean): Boolean; override;
{$ELSE}
    procedure SetDBFlag(Flag: Integer; Value: Boolean); override;
{$ENDIF}
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetQBEText: PChar;
    procedure ExecQBE;
    function ParamByName(const Value: string): TParam;
    procedure Prepare;
    procedure RefreshQuery;
    procedure UnPrepare;
{$IFNDEF RX_D3}
    function IsEmpty: Boolean;
{$ENDIF}
    property Local: Boolean read FLocal;
    property ParamCount: Word read GetParamsCount;
    property Prepared: Boolean read FPrepared write SetPrepare;
    property StmtHandle: HDBIStmt read FStmtHandle;
{$IFDEF WIN32}
    property Text: string read FText;
    property RowsAffected: Integer read GetRowsAffected;
{$ELSE}
    property Text: PChar read FText;
{$ENDIF}
  published
{$IFDEF RX_D5}
    property AutoRefresh;
{$ENDIF}
    property AuxiliaryTables: Boolean read FAuxiliaryTables write FAuxiliaryTables default True;
    property ParamCheck: Boolean read FParamCheck write FParamCheck default True;
    property StartParam: Char read FStartParam write SetStartParam default DefQBEStartParam;
    { Ensure StartParam is declared before QBE }
    property QBE: TStrings read FQBE write SetQuery;
    { Ensure QBE is declared before Params }
    property BlankAsZero: Boolean read FBlankAsZero write FBlankAsZero default False;
    property Params: TParams read FParams write SetParamsList {$IFDEF RX_D4} stored False {$ENDIF};
    property RequestLive: Boolean read FRequestLive write FRequestLive default False;
    property UpdateMode;
{$IFDEF WIN32}
    property UpdateObject;
  {$IFDEF RX_D3}
    property Constrained: Boolean read FConstrained write FConstrained default False;
    property Constraints stored ConstraintsStored;
  {$ENDIF}
{$ENDIF}
  end;

implementation

uses DBConsts, {$IFDEF RX_D3} BDEConst, {$ENDIF} DBUtils, BdeUtils;

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

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

{ TQBEQuery }

constructor TQBEQuery.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FQBE := TStringList.Create;
  TStringList(QBE).OnChange := QueryChanged;
  FParams := TParams.Create{$IFDEF RX_D4}(Self){$ENDIF};
  FStartParam := DefQBEStartParam;
  FParamCheck := True;
  FAuxiliaryTables:= True;
{$IFNDEF WIN32}
  FText := nil;
{$ELSE}
  FRowsAffected := -1;
{$ENDIF}
  FRequestLive := False;
end;

destructor TQBEQuery.Destroy;
begin
  Destroying;
  Disconnect;
  QBE.Free;
{$IFNDEF WIN32}
  StrDispose(FText);
{$ENDIF}
  FParams.Free;
  inherited Destroy;
end;

procedure TQBEQuery.Disconnect;
begin
  Close;
  UnPrepare;
end;

procedure TQBEQuery.RefreshQuery;
var
  Bookmark: TBookmark;
begin
  DisableControls;
  Bookmark := GetBookmark;
  try
    Close;
    Open;
    try
      GotoBookmark(Bookmark);
    except
      { ignore exceptions }
    end;
  finally
    FreeBookmark(Bookmark);
    EnableControls;
  end;
end;

procedure TQBEQuery.SetPrepare(Value: Boolean);
begin
  if Value then Prepare
  else UnPrepare;
end;

procedure TQBEQuery.Prepare;
begin
  SetDBFlag(dbfPrepared, True);
  SetPrepared(True);
end;

procedure TQBEQuery.UnPrepare;
begin
  SetPrepared(False);
  SetDBFlag(dbfPrepared, False);
end;

procedure TQBEQuery.SetStartParam(Value: Char);
begin
  if Value <> FStartParam then begin
    FStartParam := Value;
    QueryChanged(nil);
  end;
end;

procedure TQBEQuery.SetQuery(Value: TStrings);
begin
{$IFDEF WIN32}
  if QBE.Text <> Value.Text then begin
{$ENDIF}
    Disconnect;
    TStringList(QBE).OnChange := nil;
    QBE.Assign(Value);
    TStringList(QBE).OnChange := QueryChanged;
    QueryChanged(nil);
{$IFDEF WIN32}
  end;
{$ENDIF}
end;

procedure TQBEQuery.QueryChanged(Sender: TObject);
var
  List: TParams;
begin
{$IFDEF RX_D4}
  if not (csReading in ComponentState) then begin
{$ENDIF RX_D4}
    Disconnect;
  {$IFDEF WIN32}
    FText := QBE.Text;
  {$ELSE}
    StrDispose(FText);
    FText := QBE.GetText;
  {$ENDIF WIN32}
    if ParamCheck or (csDesigning in ComponentState) then begin
      List := TParams.Create{$IFDEF RX_D4}(Self){$ENDIF};
      try
        CreateParams(List, PChar(Text));
        List.AssignValues(FParams);
    {$IFDEF RX_D4}
        FParams.Clear;
        FParams.Assign(List);
      finally
    {$ELSE}
        FParams.Free;
        FParams := List;
      except
    {$ENDIF RX_D4}
        List.Free;
      end;
    end;
{$IFDEF RX_D4}
    DataEvent(dePropertyChange, 0);
  end
  else begin
    FText := QBE.Text;
    FParams.Clear;
    CreateParams(FParams, PChar(Text));
  end;
{$ENDIF RX_D4}
end;

procedure TQBEQuery.SetParamsList(Value: TParams);
begin
  FParams.AssignValues(Value);
end;

{$IFDEF RX_D4}
procedure TQBEQuery.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('ParamData', ReadParamData, WriteParamData, True);
end;

procedure TQBEQuery.ReadParamData(Reader: TReader);
begin
  Reader.ReadValue;
  Reader.ReadCollection(FParams);
end;

procedure TQBEQuery.WriteParamData(Writer: TWriter);
begin
  Writer.WriteCollection(Params);
end;
{$ENDIF}

function TQBEQuery.GetParamsCount: Word;
begin
  Result := FParams.Count;
end;

procedure TQBEQuery.ReplaceParams(QBEText: TStrings);

  function ReplaceString(const S: string): string;
  var
    I, J, P, LiteralChars: Integer;
    Param: TParam;
    Temp: string;
    Found: Boolean;
  begin
    Result := S;
    for I := Params.Count - 1 downto 0 do begin
      Param := Params[I];
      if Param.DataType = ftUnknown then
        Continue; { ignore undefined params }
      repeat
        P := Pos(StartParam + Param.Name, Result);
        Found := (P > 0) and ((Length(Result) = P + Length(Param.Name)) or
          NameDelimiter(Result[P + Length(Param.Name) + 1]));
        if Found then begin
          LiteralChars := 0;
          for J := 1 to P - 1 do