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

unit DBFilter;

interface

{$I RX.INC}
{$T-}

{$IFDEF WIN32}
uses SysUtils, Windows, Messages, Classes, Controls, Forms,
  Graphics, Menus, StdCtrls, ExtCtrls, Bde, DB, DBTables;
{$ELSE}
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Controls, Forms,
  Graphics, Menus, StdCtrls, ExtCtrls, DBITypes, DB, DBTables;
{$ENDIF}

type

{ TRxDBFilter }

  TFilterLogicCond = (flAnd, flOr); { for captured DataSet }
  TDBFilterOption = TFilterOption;
  TDBFilterOptions = TFilterOptions;

  TFilterEvent = function (Sender: TObject; DataSet: TDataSet): Boolean of object;

  TDataSetStorage = record { for internal use only }
    FBof: Boolean;
    FEof: Boolean;
    State: TDataSetState;
    CanModify: Boolean;
    BeforePost: TDataSetNotifyEvent;
    BeforeCancel: TDataSetNotifyEvent;
    BeforeInsert: TDataSetNotifyEvent;
    BeforeEdit: TDataSetNotifyEvent;
  end;

  TRxDBFilter = class(TComponent)
  private
    FParser: TObject;
    FDataLink: TDataLink;
    FIgnoreDataEvents: Boolean;
    FPriority: Word;
    FOptions: TDBFilterOptions;
    FLogicCond: TFilterLogicCond;
    FFilter: TStrings;
    FExprHandle: hDBIFilter;
    FFuncHandle: hDBIFilter;
    FDataHandle: hDBICur;
    FActive: Boolean;
    FCaptured: Boolean;
    FStreamedActive: Boolean;
    FActivating: Boolean;
    FStorage: TDataSetStorage;
    FOnFiltering: TFilterEvent;
    FOnActivate: TNotifyEvent;
    FOnDeactivate: TNotifyEvent;
    FOnSetCapture: TNotifyEvent;
    FOnReleaseCapture: TNotifyEvent;
    procedure SetDataSource(Value: TDataSource);
    function GetDataSource: TDataSource;
    function BuildTree: Boolean;
    procedure DestroyTree;
    procedure SetFilter(Value: TStrings);
    procedure SetOptions(Value: TDBFilterOptions);
    procedure SetOnFiltering(const Value: TFilterEvent);
    procedure SetPriority(Value: Word);
    procedure SetLogicCond(Value: TFilterLogicCond);
    function GetFilterText: PChar;
    procedure FilterChanged(Sender: TObject);
    function CreateExprFilter: hDBIFilter;
    function CreateFuncFilter: hDBIFilter;
    procedure DropFilters;
    procedure SetFilterHandle(var Filter: HDBIFilter; Value: HDBIFilter);
    procedure RecreateExprFilter;
    procedure RecreateFuncFilter;
    procedure ActivateFilters;
    procedure DeactivateFilters;
    function RecordFilter(RecBuf: Pointer; RecNo: Longint): Smallint; {$IFDEF WIN32} stdcall; {$ENDIF WIN32}
    procedure BeforeDataPost(DataSet: TDataSet);
    procedure BeforeDataChange(DataSet: TDataSet);
    procedure BeforeDataCancel(DataSet: TDataSet);
    procedure SetActive(Value: Boolean);
  protected
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure DoActivate; dynamic;
    procedure DoDeactivate; dynamic;
    procedure ActiveChanged; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Update; virtual;
    procedure UpdateFuncFilter;
    procedure Activate;
    procedure Deactivate;
    procedure SetCapture;
    procedure ReleaseCapture;
    procedure ReadCaptureControls;
    property Captured: Boolean read FCaptured;
    property Handle: hDBIFilter read FExprHandle; { obsolete, use ExprFilter }
    property ExprFilter: hDBIFilter read FExprHandle;
    property FuncFilter: hDBIFilter read FFuncHandle;
  published
    property Active: Boolean read FActive write SetActive default False;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property Filter: TStrings read FFilter write SetFilter;
    property LogicCond: TFilterLogicCond read FLogicCond write SetLogicCond default flAnd;
    property Options: TDBFilterOptions read FOptions write SetOptions default [];
    property Priority: Word read FPriority write SetPriority default 0;
    property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
    property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
    property OnFiltering: TFilterEvent read FOnFiltering write SetOnFiltering;
    property OnSetCapture: TNotifyEvent read FOnSetCapture write FOnSetCapture;
    property OnReleaseCapture: TNotifyEvent read FOnReleaseCapture write FOnReleaseCapture;
  end;

  EFilterError = class(Exception);

procedure DropAllFilters(DataSet: TDataSet);
{$IFNDEF RX_D3}
function SetLookupFilter(DataSet: TDataSet; Field: TField;
  const Value: string; CaseSensitive, Exact: Boolean): HDBIFilter;
{$ENDIF}

implementation

uses {$IFNDEF WIN32} DBIErrs, DBIProcs, Str16, {$ENDIF} DBConsts, Dialogs,
  {$IFDEF RX_D3} DbCommon, {$ENDIF} RXDConst, VCLUtils, DBUtils, BdeUtils;

procedure DropAllFilters(DataSet: TDataSet);
begin
  if (DataSet <> nil) and DataSet.Active then begin
{$IFDEF WIN32}
    DataSet.Filtered := False;
{$ENDIF}
    DbiDropFilter((DataSet as TBDEDataSet).Handle, nil);
    DataSet.CursorPosChanged;
    DataSet.Resync([]);
  end;
end;

{ DBFilter exceptions }

procedure FilterError(Ident: Word); near;
begin
  raise EFilterError.CreateRes(Ident);
end;

procedure FilterErrorFmt(Ident: Word; const Args: array of const); near;
begin
  raise EFilterError.CreateResFmt(Ident, Args);
end;

const
  SExprNothing = '""';   { nothing token name          }
  cQuota = '''';         { qoutas for string constants }
  cFldQuotaLeft = '[';   { left qouta for field names  }
  cFldQuotaRight = ']';  { right qouta for field names }

{$IFNDEF RX_D3} {DbCommon.pas}

{ TFilterExpr }

type
  TExprNodeKind = (enField, enConst, enOperator);

  PExprNode = ^TExprNode;
  TExprNode = record
    FNext: PExprNode;
    FKind: TExprNodeKind;
    FPartial: Boolean;
    FOperator: CanOp;
    FData: string;
    FLeft: PExprNode;
    FRight: PExprNode;
  end;

  TFilterExpr = class
  private
    FDataSet: TDataSet;
    FOptions: TDBFilterOptions;
    FNodes: PExprNode;
    FExprBuffer: PCANExpr;
    FExprBufSize: Integer;
    FExprNodeSize: Integer;
    FExprDataSize: Integer;
    function FieldFromNode(Node: PExprNode): TField;
    function GetExprData(Pos, Size: Integer): PChar;
    function PutCompareNode(Node: PExprNode): Integer;
    function PutConstStr(const Value: string): Integer;
    function PutConstNode(DataType: Integer; Data: PChar;
      Size: Integer): Integer;
    function PutData(Data: PChar; Size: Integer): Integer;
    function PutExprNode(Node: PExprNode): Integer;
    function PutFieldNode(Field: TField): Integer;
    function PutNode(NodeType: NodeClass; OpType: CanOp;
      OpCount: Integer): Integer;
    procedure SetNodeOp(Node, Index, Data: Integer);
  public
    constructor Create(DataSet: TDataSet; Options: TDBFilterOptions);
    destructor Destroy; override;
    function NewCompareNode(Field: TField; Operator: CanOp;
      const Value: string): PExprNode;
    function NewNode(Kind: TExprNodeKind; Operator: CanOp;
      const Data: string; Left, Right: PExprNode): PExprNode;
    function GetFilterData(Root: PExprNode): PCANExpr;
  end;

constructor TFilterExpr.Create(DataSet: TDataSet; Options: TDBFilterOptions);
begin
  FDataSet := DataSet;
  FOptions := Options;
end;

destructor TFilterExpr.Destroy;
var
  Node: PExprNode;
begin
  if (FExprBuffer <> nil) then FreeMem(FExprBuffer, FExprBufSize);
  while FNodes <> nil do begin
    Node := FNodes;
    FNodes := Node^.FNext;
    Dispose(Node);
  end;
end;

function TFilterExpr.FieldFromNode(Node: PExprNode): TField;
begin
  Result := FDataSet.FieldByName(Node^.FData);
  if Result.Calculated then
    FilterErrorFmt(SExprBadField, [Result.FieldName]);
end;

function TFilterExpr.GetExprData(Pos, Size: Integer): PChar;
begin
{$IFDEF WIN32}
  ReallocMem(FExprBuffer, FExprBufSize + Size);
{$ELSE}
  FExprBuffer := ReallocMem(FExprBuffer, FExprBufSize, FExprBufSize + Size);
{$ENDIF}
  Move(PChar(FExprBuffer)[Pos], PChar(FExprBuffer)[Pos + Size],
    FExprBufSize - Pos);
  Inc(FExprBufSize, Size);
  Result := PChar(FExprBuffer) + Pos;
end;

function TFilterExpr.GetFilterData(Root: PExprNode): PCANExpr;
begin
  FExprBufSize := SizeOf(CANExpr);
  GetMem(FExprBuffer, FExprBufSize);
  PutExprNode(Root);
  with FExprBuffer^ do begin
    iVer := CANEXPRVERSION;
    iTotalSize := FExprBufSize;
    iNodes := $FFFF;
    iNodeStart := SizeOf(CANExpr);
    iLiteralStart := FExprNodeSize + SizeOf(CANExpr);
  end;
  Result := FExprBuffer;
end;

function TFilterExpr.NewCompareNode(Field: TField; Operator: CanOp;
  const Value: string): PExprNode;
var
  Left, Right: PExprNode;
begin
  Left := NewNode(enField, canNOTDEFINED, Field.FieldName, nil, nil);
  Right := NewNode(enConst, canNOTDEFINED, Value, nil, nil);
  Result := NewNode(enOperator, Operator, EmptyStr, Left, Right);
end;

function TFilterExpr.NewNode(Kind: TExprNodeKind; Operator: CanOp;
  const Data: string; Left, Right: PExprNode): PExprNode;
begin
  New(Result);
  with Result^ do begin
    FNext := FNodes;
    FKind := Kind;
    FPartial := False;
    FOperator := Operator;
    FData := Data;
    FLeft := Left;
    FRight := Right;
  end;
  FNodes := Result;
end;

function TFilterExpr.PutCompareNode(Node: PExprNode): Integer;
const
  ReverseOperator: array[canEQ..canLE] of CanOp = (
    canEQ, canNE, canLT, canGT, canLE, canGE);
var
  Operator: CanOp;
  Left, Right, Temp: PExprNode;
  Field: TField;
  FieldPos, ConstPos, CaseInsensitive, PartialLength, L: Integer;
  S: string;
  Buf: PChar;
begin
  Operator := Node^.FOperator;
  Left := Node^.FLeft;
  Right := Node^.FRight;
  if (Left^.FKind <> enConst) and (Right^.FKind <> enConst) then begin
    if FDataSet.FindField(Left^.FData) = nil then
      Left^.FKind := enConst
    else if FDataSet.FindField(Right^.FData) = nil then
      Right^.FKind := enConst;
  end;
  if (Left^.FKind <> enField) and (Right^.FKind <> enField) then begin
    if FDataSet.FindField(Left^.FData) <> nil then
      Left^.FKind := enField
    else if FDataSet.FindField(Right^.FData) <> nil then
      Right^.FKind := enField;
  end;
  if Right^.FKind = enField then begin
    Temp := Left;
    Left := Right;
    Right := Temp;
    Operator := ReverseOperator[Operator];
  end;
  if (Left^.FKind <> enField) or (Right^.FKind <> enConst) then
    FilterError(SExprBadCompare);
  Field := FieldFromNode(Left);
  if Right^.FData = EmptyStr then
  begin
    case Operator of
      canEQ: Operator := canISBLANK;
      canNE: Operator := canNOTBLANK;
      else FilterError(SExprBadNullTest);
    end;
    Result := PutNode(nodeUNARY, Operator, 1);
    SetNodeOp(Result, 0, PutFieldNode(Field));
  end else
  begin
    if ((Operator = canEQ) or (Operator = canNE)) and
      (Field.DataType = ftString) then
    begin
      S := Right^.FData;
      L := Length(S);
      if L <> 0 then
      begin
        CaseInsensitive := 0;
        PartialLength := 0;
        if foCaseInsensitive in FOptions then CaseInsensitive := 1;
        if Node^.FPartial then PartialLength := L
        else begin
          if not (foNoPartialCompare in FOptions) and (L > 1) and
            (S[L] = '*') then
          begin
            Delete(S, L, 1);
            PartialLength := L - 1;
          end;
        end;
        if (CaseInsensitive <> 0) or (PartialLength <> 0) then begin
          Result := PutNode(nodeCOMPARE, Operator, 4);
          SetNodeOp(Result, 0, CaseInsensitive);
          SetNodeOp(Result, 1, PartialLength);
          SetNodeOp(Result, 2, PutFieldNode(Field));
          SetNodeOp(Result, 3, PutConstStr(S));
          Exit;
        end;
      end;
    end;
    Result := PutNode(nodeBINARY, Operator, 2);
    FieldPos := PutFieldNode(Field);
    S := Right^.FData;
    Buf := AllocMem(Field.DataSize);
    try
      ConvertStringToLogicType((FDataSet as TBDEDataSet).Locale,
        FieldLogicMap(Field.DataType), Field.DataSize, Field.FieldName,
        Right^.FData, Buf);
      ConstPos := PutConstNode(FieldLogicMap(Field.DataType), Buf,
        Field.DataSize);
      SetNodeOp(Result, 0, FieldPos);
      SetNodeOp(Result, 1, ConstPos);
    finally
      FreeMem(Buf, Field.DataSize);
    end;
  end;
end;

function TFilterExpr.PutConstNode(DataType: Integer; Data: PChar;
  Size: Integer): Integer;
begin
  Result := PutNode(nodeCONST, canCONST2, 3);
  SetNodeOp(Result, 0, DataType);
  SetNodeOp(Result, 1, Size);
  SetNodeOp(Result, 2, PutData(Data, Size));
end;

function TFilterExpr.PutConstStr(const Value: string): Integer;
var
  Buffer: array[0..255] of Char;
begin
  AnsiToNative((FDataSet as TBDEDataSet).Locale, Value, Buffer,
    SizeOf(Buffer) - 1);
  Result := PutConstNode(fldZSTRING, Buffer, StrLen(Buffer) + 1);
end;

function TFilterExpr.PutData(Data: PChar; Size: Integer): Integer;
begin
  Move(Data^, GetExprData(FExprBufSize, Size)^, Size);
  Result := FExprDataSize;
  Inc(FExprDataSize, Size);
end;

function TFilterExpr.PutExprNode(Node: PExprNode): Integer;
const
  BoolFalse: WordBool = False;
var
  Field: TField;
begin
  Result := 0;
  case Node^.FKind of
    enField:
      begin
        Field := FieldFromNode(Node);
        if Field.DataType <> ftBoolean then
          FilterErrorFmt(SExprNotBoolean, [Field.FieldName]);
        Result := PutNode(nodeBINARY, canNE, 2);
        SetNodeOp(Result, 0, PutFieldNode(Field));
        SetNodeOp(Result, 1, PutConstNode(fldBOOL, @BoolFalse,
          SizeOf(WordBool)));
      end;
    enOperator:
      case Node^.FOperator of
        canEQ..canLE:
          Result := PutCompareNode(Node);
        canAND, canOR:
          begin
            Result := PutNode(nodeBINARY, Node^.FOperator, 2);
            SetNodeOp(Result, 0, PutExprNode(Node^.FLeft));
            SetNodeOp(Result, 1, PutExprNode(Node^.FRight));
          end;
        else
          Result := PutNode(nodeUNARY, canNOT, 1);
          SetNodeOp(Result, 0, PutExprNode(Node^.FLeft));
      end; { case Node^.FOperator }
    else FilterError(SExprIncorrect);
  end; { case Node^.FKind }
end;

function TFilterExpr.PutFieldNode(Field: TField): Integer;
var
  Buffer: array[0..255] of Char;
begin
  AnsiToNative((FDataSet as TBDEDataSet).Locale, Field.FieldName, Buffer,
    SizeOf(Buffer) - 1);
  Result := PutNode(nodeFIELD, canFIELD2, 2);
  SetNodeOp(Result, 0, Field.FieldNo);
  SetNodeOp(Result, 1, PutData(Buffer, StrLen(Buffer) + 1));
end;

function TFilterExpr.PutNode(NodeType: NodeClass; OpType: CanOp;
  OpCount: Integer): Integer;
var
  Size: Integer;
begin
  Size := SizeOf(CANHdr) + OpCount * SizeOf(Word);
  with PCANHdr(GetExprData(SizeOf(CANExpr) + FExprNodeSize, Size))^ do begin
    nodeClass := NodeType;
    canOp := OpType;
  end;
  Result := FExprNodeSize;
  Inc(FExprNodeSize, Size);
end;

procedure TFilterExpr.SetNodeOp(Node, Index, Data: Integer);
begin
  PWordArray(PChar(FExprBuffer) + (SizeOf(CANExpr) + Node +
    SizeOf(CANHdr)))^[Index] := Data;
end;

{ SetLookupFilter }

function SetLookupFilter(DataSet: TDataSet; Field: TField;
  const Value: string; CaseSensitive, Exact: Boolean): HDBIFilter;
var
  Options: TDBFilterOptions;
  Filter: TFilterExpr;
  Node: PExprNode;
begin
  if not CaseSensitive then Options := [foNoPartialCompare, foCaseInsensitive]
  else Options := [foNoPartialCompare];
  Filter := TFilterExpr.Create(DataSet, Options);
  try
    Node := Filter.NewCompareNode(Field, canEQ, Value);
    if not Exact then Node^.FPartial := True;
    Check(DbiAddFilter((DataSet as TBDEDataSet).Handle, 0, 2, False,
      Filter.GetFilterData(Node), nil, Result));
    DataSet.CursorPosChanged;
    DataSet.Resync([]);
  finally
    Filter.Free;
  end;
end;

{ TExprParser }

type
  TExprToken = (etEnd, etSymbol, etName, etLiteral, etLParen, etRParen,
    etEQ, etNE, etGE, etLE, etGT, etLT);

  TExprParser = class
  private
    FFilter: TFilterExpr;
    FText: PChar;
    FSourcePtr: PChar;
    FTokenPtr: PChar;
    FTokenString: string;
    FToken: TExprToken;
    FFilterData: PCANExpr;
    FDataSize: Integer;
    procedure NextToken;
    function ParseExpr: PExprNode;
    function ParseExpr2: PExprNode;
    function ParseExpr3: PExprNode;
    function ParseExpr4: PExprNode;
    function ParseExpr5: PExprNode;
    function TokenName: string;
    function TokenSymbolIs(const S: string): Boolean;
  public
    constructor Create(DataSet: TDataSet; const Text: PChar;