(*****************************************************************************)
(* MODULE: BSEFILT^                                                          *)
(* RIGHTS: Reggatta Systems, Inc. - COPYRIGHT 1995 - 1998                    *)
(* DESCR.: This module contains the Filter Object used by the Table Class    *)
(*                                                                           *)
(*                                                                           *)
(* NOTES :                                                                   *)
(*                                                                           *)
(* TFilterRec:         This is a simple class to hold the fields used        *)
(*                     when calling DBIAddFilter.  The TbaseTable class      *)
(*                     keeps these in a collection.                          *)
(*                                                                           *)
(*****************************************************************************)
Unit BseFilt;
{$I BSE.INC}
{$I BAPI.INC}
Interface
Uses
  Classes,

  Windows,
  BDE,

  BseTypes,
  BseColl,
  BseTable;


Type
  PFieldTypeRec = ^TFieldTypeRec;
  TFieldTypeRec =
  Record
    Case Integer of
      1: ( fldFloat    : Double );
      2: ( fldBytes    : Array[0..255] of byte );
      3: ( fldInt32    : LongInt );
      4: ( fldInt16    : Word );
      5: ( fldDate     : Double );
      6: ( fldTime     : Double );
      7: ( fldBool     : Word   );
      8: ( fldVarBytes : ShortString );
      9: ( fldZString  : Array[0..255] of Char );
  end;

  pCANVALUE = ^CANVALUE;
  CANVALUE =
  Record
    nodeClass         : NODEClass;
    canOp             : CANOp;
    canValue          : TFieldTypeRec;
    canType           : Word;
    canSize           : Word;
  end;

  pENGCANNode = ^ENGCANNode;
  ENGCANNode =
  Record
    Case Integer of
      1: (canHdr      : CANHdr);
      2: (canUnary    : CANUnary);
      3: (canBinary   : CANBinary);
      4: (canField    : CANField);
      5: (canConst    : CANConst);
      6: (canTuple    : CANTuple);
      7: (canContinue : CANContinue);
      8: (canCompare  : CANCompare);
      9: (canValue    : CANValue);
  end;

  TFilterListItem =
  Class( TObject )
    Private
      FOwner       : TBaseTable;
      FClientData  : Longint;
      FPriority    : Integer;
      FCanAbort    : Bool;
      FExpression  : pCANExpr;
      FExprSize    : Word;
      FPfFilter    : pfGENFilter;
      FActive      : Bool;
      FRecBuff     : Pointer;
    Public
      Property Active : Bool
        Read  FActive
        Write FActive;

      Constructor Create( Owner : TBaseTable; CD : Longint; P : Integer; CA : Bool;
                    Exp : pCANExpr; pfFilt : pfGENFilter );
      Destructor Destroy; Override;
      Function   EvaluateExpression( pRecBuff : Pointer ) : Boolean;
      Procedure  GetFilterInfo( Index : Word; var FilterInfo : FilterInfo );
      Function   EvaluateNode( P : PENGCANNode; Var E : ENGCANNode ) : Boolean;
      Function   GetNodePtr( Offset : Word ) : pENGCANNode;
      Function   GetLiteralPtr( Offset : Word ) : PFieldTypeRec;
      Function   EvaluateUNARY( P : PENGCANNode; Var E : ENGCANNode ) : Boolean;
      Function   EvaluateBINARY( P : PENGCANNode; Var E : ENGCANNode ) : Boolean;
      Function   EvaluateCOMPARE( P : pENGCANNode; Var E : ENGCANNode ) : Boolean;
      Function   EvaluateLOGICAL( P : PENGCANNode; Var E : ENGCANNode ) : Boolean;
      Function   EvaluateFIELD( P : PENGCANNode; Var E : ENGCANNode ) : Boolean;
      Function   EvaluateCONST( P : PENGCANNode; Var E : ENGCANNode ) : Boolean;
      Function   CompareValues( A, B : pENGCANNode; IgnoreCase : Boolean; Partial : Integer ) : Integer;
  end;


implementation
Uses
  SysUtils,


  BseUtils,
  BseErrs;


Constructor TFilterListItem.Create( Owner : TBaseTable; CD : Longint; P : Integer; CA : Bool;
              Exp : pCANExpr; pfFilt : pfGENFilter );
begin
  Inherited Create;
  FOwner       := Owner;
  FClientData  := CD;
  FPriority    := P;
  FCanAbort    := CA;
  if Assigned( Exp ) then
  begin
    FExprSize   := CANExpr( Exp^ ).iTotalSize;
    If ( FExprSize > 0 ) then
    begin
      GetMem( FExpression, FExprSize );
      If Assigned( FExpression ) then
        Move( Exp^, FExpression^, FExprSize );
    end;
  end;
  FPfFilter   := pfFilt;
  FActive     := FALSE;
end;


Destructor TFIlterListItem.Destroy;
begin
  If ( FExprSize > 0 ) and Assigned( FExpression ) then
    FreeMem( FExpression, FExprSize );
  Inherited Destroy;
end;


Procedure TFilterListItem.GetFilterInfo( Index : Word; var FilterInfo : FilterInfo );
begin
  MoveZero( FilterInfo, Sizeof( FilterInfo ) );
  With FilterInfo Do
  begin
    iFilterId       := Index;                             { Id for filter }
    hFilter         := @Self;                             { Filter handle }
    iClientData     := FClientData;                       { Client supplied data }
    iPriority       := FPriority;                         { 1..N with 1 being highest }
    bCanAbort       := FCanAbort;                         { TRUE : pfFilter can return ABORT }
    pfFilter        := FpfFilter;                         { Client filter function }
    pCanExpr        := FExpression;                       { Supplied expression }
    bActive         := FActive;                           { TRUE : filter is active }
  end;
end;


Function TFilterListItem.GetNodePtr( Offset : Word ) : pENGCANNode;
var
  i : word;
begin
  i := CANExpr( FExpression^ ).iNodeStart + Offset;
  Result := pENGCANNode( @MemPtr( FExpression )^[ i ] );
end;


Function TFilterListItem.GetLiteralPtr( Offset : Word ) : PFieldTypeRec;
var
  i : word;
begin
  i := CANExpr( FExpression^ ).iLiteralStart + Offset;
  Result := PFieldTypeRec( @MemPtr( FExpression )^[ i ] );
end;


Function TFilterListItem.EvaluateExpression( pRecBuff : Pointer ) : Boolean;
var
  E  : ENGCANNode;
  P  : pENGCANNode;
  i  : integer;
begin
  If FActive then
  begin
    FRecBuff := pRecBuff;
    If Assigned( FpfFilter ) then
    begin
      i := 0;
      Try
        i := FpfFilter( FClientData, pRecBuff, Longint( 0 ) );
      Finally
        Result := ( i <> 0 );
      end;
    end
    else
      Result := TRUE;
    If Result and Assigned( FExpression ) then
    begin
      Try
        P      := GetNodePtr( 0 );
        Result := EvaluateNode( P, E );
      Except
        Result := FALSE;
      end;
    end;
  end
  else
    Result := FALSE;
end;


Function TFilterListItem.EvaluateNode( P : pENGCANNode; Var E : ENGCANNode ) : Boolean;
begin
  MoveZero( E, Sizeof( E ) );
  Case P^.CanHdr.NodeClass of
    nodeNULL:                                               { Null node                  (*) }
      Result := FALSE;
    nodeUNARY:                                              { Node is a unary            (*) }
      Result := EvaluateUNARY( P, E );
    nodeBINARY:                                             { Node is a binary           (*) }
      if ( P^.CanHdr.CanOp in [ canAND, canOR ] ) then
        Result := EvaluateLOGICAL( P, E )
      else
        Result := EvaluateBINARY( P, E );
    nodeCOMPARE:
      Result := EvaluateCOMPARE( P, E );
    nodeFIELD:                                              { Node is a field            (*) }
      Result := EvaluateFIELD( P, E );
    nodeCONST:                                              { Node is a constant             }
      Result := EvaluateCONST( P, E );
    nodeTUPLE:
      Result := FALSE;
    nodeCONTINUE:                                           { Node is a continue node    (*) }
      Result := ( P^.canCONTINUE.iContOperand <> 0 );
    nodeUDF:
      Result := FALSE;
  else
    Result := FALSE;
  end;
end;


Function TFilterListItem.EvaluateUNARY( P : pENGCANNode; Var E : ENGCANNode ) : Boolean;
var
  LeftElement  : ENGCANNode;
  NextNode     : pENGCANNode;
begin
  Result := FALSE;
  NextNode := GetNodePtr( P^.CanUNARY.iOperand1 );
  if EvaluateNode( NextNode, LeftElement ) then
  begin
    Case P^.CanHdr.CanOP of
      canISBLANK:
        Result := IsBlank( @LeftElement.CanValue.CanValue, LeftElement.CanValue.CanSize );
      canNOTBLANK:
        Result := not IsBlank( @LeftElement.CanValue.CanValue, LeftElement.CanValue.CanSize );
      canNOT:
        Result := ( LeftElement.CanCONTINUE.iContOperand = 0 );
    end;
  end;
  E.CanHdr.NodeClass         := nodeCONTINUE;
  E.CanHdr.canOp             := canCONTINUE2;
  E.CanContinue.iContOperand := Word( Result );
end;


Function TFilterListItem.EvaluateBINARY( P : pENGCANNode; Var E : ENGCANNode ) : Boolean;
var
  RightElement : ENGCANNode;
  LeftElement  : ENGCANNode;
  NextNode     : pENGCANNode;
  tmp          : Integer;
begin
  Result := FALSE;
  NextNode := GetNodePtr( P^.CanBINARY.iOperand1 );
  if EvaluateNode( NextNode, LeftElement ) then
  begin
    NextNode := GetNodePtr( P^.CanBINARY.iOperand2 );
    if EvaluateNode( NextNode, RightElement ) then
    begin
      tmp := CompareValues( @LeftElement, @RightElement, FALSE, 0 );
      Case P^.CanHdr.CanOP of
        canEQ:
          Result := ( tmp  = 0  );
        canNE:
          Result := ( tmp <> 0  );
        canGT:
          Result := ( tmp  > 0  );
        canLT:
          Result := ( tmp  < 0  );
        canGE:
          Result := ( tmp >= 0  );
        canLE:
          Result := ( tmp <= 0  );
      end;
    end;
  end;
  E.CanHdr.NodeClass         := nodeCONTINUE;
  E.CanHdr.canOp             := canCONTINUE2;
  E.CanContinue.iContOperand := Word( Result );
end;


Function TFilterListItem.EvaluateCOMPARE( P : pENGCANNode; Var E : ENGCANNode ) : Boolean;
var
  RightElement : ENGCANNode;
  LeftElement  : ENGCANNode;
  NextNode     : pENGCANNode;
  tmp          : Integer;
begin
  Result := FALSE;
  NextNode := GetNodePtr( P^.CanCOMPARE.iOperand1 );
  if EvaluateNode( NextNode, LeftElement ) then
  begin
    NextNode := GetNodePtr( P^.CanCOMPARE.iOperand2 );
    if EvaluateNode( NextNode, RightElement ) then
    begin
      tmp := CompareValues( @LeftElement, @RightElement,
               P^.CanCOMPARE.bCaseInsensitive, P^.CanCOMPARE.iPartialLen );
      Case P^.CanHdr.CanOP of
        canEQ:
          Result := ( tmp  = 0  );
        canNE:
          Result := ( tmp <> 0  );
        canGT:
          Result := ( tmp  > 0  );
        canLT:
          Result := ( tmp  < 0  );
        canGE:
          Result := ( tmp >= 0  );
        canLE:
          Result := ( tmp <= 0  );
      end;
    end;
  end;
  E.CanHdr.NodeClass         := nodeCONTINUE;
  E.CanHdr.canOp             := canCONTINUE2;
  E.CanContinue.iContOperand := Word( Result );
end;


Function TFilterListItem.EvaluateLOGICAL( P : pENGCANNode; Var E : ENGCANNode ) : Boolean;
var
  RightElement : ENGCANNode;
  LeftElement  : ENGCANNode;
  NextNode     : pENGCANNode;
begin
  Result := FALSE;

  E.CanHdr.NodeClass := nodeCONTINUE;
  E.CanHdr.canOp     := canCONTINUE2;

  NextNode := GetNodePtr( P^.CanBINARY.iOperand1 );
  EvaluateNode( NextNode, LeftElement );
  if ( LeftElement.CanCONTINUE.iContOperand <> 0 ) then
  begin
    Case P^.CanHdr.CanOP of
      canAND:
        begin
          NextNode := GetNodePtr( P^.CanBINARY.iOperand2 );
          EvaluateNode( NextNode, RightElement );
          Result := ( RightElement.CanCONTINUE.iContOperand <> 0 );
        end;
      canOR:
        Result := TRUE;
    end;
    If Result then
    begin
      E.CanContinue.iContOperand := Word( Result );
      Exit;
    end;
  end;

  Case P^.CanHdr.CanOP of
    canAND:
      Result := FALSE;
    canOR:
      begin
        NextNode := GetNodePtr( P^.CanBINARY.iOperand2 );
        EvaluateNode( NextNode, RightElement );
        Result := ( RightElement.CanCONTINUE.iContOperand <> 0 );
      end;
  end;

  E.CanContinue.iContOperand := Word( Result );
end;


Function TFilterListItem.EvaluateFIELD( P : pENGCANNode; Var E : ENGCANNode ) : Boolean;
const
  canLITERAL = canNOTDEFINED;
var
  tmp          : Integer;
  FieldDesc    : TFieldCacheItem;
  LiteralPtr   : PFieldTypeRec;
  blank        : bool;
begin
  Result := FALSE;
  Try
    LiteralPtr := GetLiteralPtr( P^.canFIELD.iNameOffset );
    if ( StrLen( LiteralPtr^.fldZString ) > 0 ) then
    begin
      Result              := TRUE;
      E.CanHdr.NodeClass  := nodeCONTINUE;
      E.CanHdr.canOp      := canLITERAL;
      tmp := FOwner.Fields.FieldNumberFromName( @LiteralPtr^.FldZSTRING );
      if ( tmp > 0 ) then
      begin
        FieldDesc           := FOwner.Fields[ tmp ];
        E.CanValue.canType  := FieldDesc.FieldType;
        E.CanValue.canSize  := FieldDesc.FieldLength;
        Try
          FOwner.TranslateGet( FieldDesc, FRecBuff, @E.CanValue.CanValue, blank );
        Except
          on E:ETitanEngineError do
            Result := FALSE;
        end;
      end
      else
      begin
        E.CanValue.canType  := fldVarBytes;
        E.CanValue.CanValue.fldVarBytes := RemoveChar( StrPas( LiteralPtr^.FldZString ), '"' );
        E.CanValue.canSize  := Length( E.CanValue.CanValue.fldVarBytes );
      end;
    end;
  Finally
    if not Result then
    begin
      E.CanHdr.NodeClass         := nodeCONTINUE;
      E.CanHdr.canOp             := canCONTINUE2;
      E.CanContinue.iContOperand := Word( Result );
    end;
  end;
end;


Function TFilterListItem.EvaluateCONST( P : pENGCANNode; Var E : ENGCANNode ) : Boolean;
const
  canLITERAL = canNOTDEFINED;
var
  LiteralPtr   : PFieldTypeRec;
begin
  E.CanHdr.NodeClass  := nodeCONTINUE;
  E.CanHdr.canOp      := canLITERAL;
  E.CanValue.canType  := P^.canConst.iType;
  E.CanValue.canSize  := P^.canConst.iSize;
  LiteralPtr := GetLiteralPtr( P^.canCONST.iOffset );
  Move( LiteralPtr^, E.canValue.canValue, E.canValue.canSize );
  Result := TRUE;
end;


Function TFilterListItem.CompareValues( A, B : pENGCANNode;
           IgnoreCase : Boolean; Partial : Integer ) : Integer;

  Procedure ConvertToBuffer( Var E : ENGCANNode; var Buffer : ShortString );
  begin
    Case E.CanValue.CanType of
      fldFloat:
        Buffer := Format( '%f', [ E.CanValue.CanValue.fldFloat ] );
      fldBytes:
        begin
          SetLength( Buffer, E.CanValue.CanSize );
          Move( E.CanValue.CanValue, Buffer[ 1 ], E.CanValue.CanSize );
        end;
      fldInt32:
        Buffer := Format( '%10.10d', [ E.CanValue.CanValue.fldINT32 ] );
      fldInt16:
        Buffer := Format( '%5.5d', [ E.CanValue.CanValue.fldINT16 ] );
      fldDate:
        Buffer := DatetoStr( E.CanValue.CanValue.fldDate );
      fldTime:
        Buffer := TimetoStr( E.CanValue.CanValue.fldTime );
      fldBool:
        if ( E.CanValue.CanValue.fldBool <> 0 ) then
          Buffer := '1'
        else
          Buffer := '0';
      fldVarBytes:
        Buffer := E.CanValue.CanValue.fldVarBytes;
      fldZString:
        Buffer := StrPas( E.CanValue.CanValue.fldZString );
    else
      Buffer := '';
    end;
  end;

var
  ABuff : ShortString;
  BBuff : ShortString;
begin
  Result := 0;
  If ( Partial = 0 ) then
    Partial := A^.CanValue.canSize;
  If ( A^.canValue.canType = B^.canValue.canType ) then
    Result := FOwner.TranslateCmp( A^.CanValue.CanType, NIL, Partial, IgnoreCase,
                @A^.CanValue.CanValue, @B^.CanValue.CanValue )
  else
  begin
    ConvertToBuffer( A^, ABuff );
    ConvertToBuffer( B^, BBuff );
    if ( ABuff < BBuff ) then
      Result := -1
    else
      if ( ABuff > BBuff ) then
        Result := 1;
  end;
end;


end.
