vg2canexpr.pas

Midas.dll全部源码

{$I hb.inc }
{$D-,L-}

unit vg2CanExpr;

interface
uses SysUtils,Masks;
 type
 CANOp=Integer;
  CANOpEnum=
  (canNOTDEFINED, canISBLANK, canNOTBLANK, canEQ, canNE, canGT, canLT,
    canGE, canLE, canNOT, canAND, canOR, canTUPLE2, canFIELD2, canCONST2,
    canMINUS, canADD, canSUB, canMUL, canDIV, canMOD, canREM, canSUM,
    canCOUNT, canMIN, canMAX, canAVG, canCONT, canUDF2, canCONTINUE2,
    canLIKE, canIN, canLIST2, canUPPER, canLOWER, canFUNC2, canLISTELEM2,
    canASSIGN);

  NODEClass=Integer;
  NODEClassEnum=
  (nodeNULL, nodeUNARY, nodeBINARY, nodeCOMPARE, nodeFIELD, nodeCONST,
    nodeTUPLE, nodeCONTINUE, nodeUDF, nodeLIST, nodeFUNC, nodeLISTELEM);
  pCANHdr=^CANHdr;
  CANHdr=record
    nodeClass: NODEClass;
    canOp: CANOp;
  end;

  pCANUnary=^CANUnary;
  CANUnary=record
    nodeClass: NODEClass;
    canOp: CANOp;
    iOperand1: Word;
  end;

  pCANBinary=^CANBinary;
  CANBinary=record 
    nodeClass: NODEClass;
    canOp: CANOp;
    iOperand1: Word;
    iOperand2: Word;
  end;

  pCANField=^CANField;
  CANField=record 
    nodeClass: NODEClass;
    canOp: CANOp;
    iFieldNum: Word;
    iNameOffset: Word;
  end;

  pCANConst=^CANConst;
  CANConst=record 
    nodeClass: NODEClass;
    canOp: CANOp;
    iType: Word;
    iSize: Word;
    iOffset: Word;
  end;

  pCANTuple=^CANTuple;
  CANTuple=record 
    nodeClass: NODEClass;
    canOp: CANOp;
    iSize: Word;
  end;

  pCANContinue=^CANContinue;
  CANContinue=record 
    nodeClass: NODEClass;
    canOp: CANOp;
    iContOperand: Word;
  end;

  pCANCompare=^CANCompare;
  CANCompare=record 
    nodeClass: NODEClass;
    canOp: CANOp;
    bCaseInsensitive: WordBool;
    iPartialLen: Word;
    iOperand1: Word;
    iOperand2: Word;
  end;

  pCANFunc=^CANFunc;
  CANFunc=record 
    nodeClass: NODEClass;
    canOp: CANOp;
    iNameOffset: Word;
    iElemOffset: Word;
  end;

  pCANListElem=^CANListElem;
  CANListElem=record 
    nodeClass: NODEClass;
    canOp: CANOp;
    iOffset: Word;
    iNextOffset: Word;
  end;

const
  iLangSQL = $00;
  iDbaseExpr = $02;

type
  pCANUdf=^CANUdf;
  CANUdf=record
    nodeClass: NODEClass;
    canOp: CANOp;
    iOffSzFuncName: Word;
    iOperands: Word;
    iDrvDialect: Word;
    iOffSzUDF: Word;
  end;

  pCANList=^CANList;
  CANList=record 
    nodeClass: NODEClass;
    canOp: CANOp;
    iType: Word;
    iTotalSize: Word;
    iElemSize: Word;
    iElems: Word;
    iOffset: Word;
  end;

  pCANNode=^CANNode;
  CANNode=record
    case Integer of
     0: (canHdr: CANHdr);
     1: (canUnary: CANUnary);
     2: (canBinary: CANBinary);
     3: (canField: CANField);
     4: (canConst: CANConst);
     5: (canTuple: CANTuple);
     6: (canContinue: CANContinue);
     7: (canCompare: CANCompare);
     8: (canList: CANList);
     9: (canFunc: CANFunc);
     10: (canListElem: CANListElem)
  end;

const
  CANEXPRVERSION = $02;
type
  ppCANExpr=^pCANExpr;
  pCANExpr=^CANExpr;
  CANExpr=record
    iVer: Word;
    iTotalSize: Word;
    iNodes: Word;
    iNodeStart: Word;
    iLiteralStart: Word;
  end;
  TEvalFunction = (efUnknown, efSum, efMin, efMax, efAvg, efCount, efUpper, efLower,
    efSubString, efTrim, efTrimLeft, efTrimRight, efYear, efMonth, efDay,
    efHour, efMinute, efSecond, efGetDate, efDate, efTime, efIIF);


  Tvg2ExprEvaluator=class (TObject)
  private
    FExpr: PCanExpr;
    FOpList: Variant;
    function CompareOperandsEx (var Op1: Variant;
     var Op2: Variant; CaseIns: Boolean;
      PartialLen: Word; CompareLike: Boolean):
      Integer;
    function CompareOperandsEx2 (var Op1: Variant;
      var Op2: Variant; var iFldType1: Integer;
      var iFldLen1: Integer; var iFldType2: Integer;
      var iFldLen2: Integer): Integer;
    function CompareOperands (Op1: Variant;
      Op2: Variant): Integer;
    function Exists (var Op1: Variant; var Op2: Variant):
      Boolean;
    function GetConstantValue (DataType: Word; Size: Word;
      Offset: Word; var iFldType: Integer;
      var iFldLen: Integer): Variant;
    function GetFieldValue (FieldNo: Word; Offset: Word;
      var iFldType: Integer; var iFldLen: Integer):
      Variant;
    function GetFuncValue (Func: TEvalFunction; Offset: Word;
      var iFldType: Integer; var iFldLen: Integer):
      Variant;
    function GetFuncValueInternal (Func: TEvalFunction;
      Args: Variant; var iFldType: Integer;
      var iFldLen: Integer): Variant;
    function GetOperandValue (Offset: Word;
      var iFldType: Integer; var iFldLen: Integer):
      Variant;
  protected
    function DoGetFieldValue(FieldNo: Word; const FieldName: string;
      var iFldType, iFldLen: Integer): Variant; virtual;
    procedure DoFirst; virtual;
    procedure DoNext; virtual;
    function DoGetEOF: Boolean; virtual;
    procedure DoBeginAgg; virtual;
    procedure DoEndAgg; virtual;
    procedure DoBeginEvaluate; virtual;
    procedure DoEndEvaluate; virtual;
  public
    destructor Destroy; override;
    procedure SetData(Value: PCanExpr); virtual;
    function Evaluate(var iFldType, iFldLen: Integer): Variant;
    property Data: PCanExpr read FExpr;
  end;
  ENotSupported = class (Exception);

const
 // efAggregates  = [efSum, efMin, efMax, efAvg, efCount];
  efAggregates = [efSum..efCount];
  fldUNKNOWN = $00;
  fldZSTRING = $01;
  fldDATE = $02;
  fldBLOB = $03;
  fldBOOL = $04;
  fldINT16 = $05;
  fldINT32 = $06;
  fldFLOAT = $07;
  fldBCD = $08;
  fldTIME = $0A;
  fldTIMESTAMP = $0B;
  fldUINT16 = $0C;
  fldUINT32 = $0D;
  fldFLOATIEEE = $0E;
  fldVARBYTES = $0F;
  fldINT64 = $12;
  fldUINT64 = $13;
function IsNumeric(DataType: Integer): Boolean;
function IsTemporal(DataType: Integer): Boolean;

procedure NotSupported;

implementation
uses Variants,vg2Consts,vg3SysUtils,vg2BCDUtils;


function IsNumeric(DataType: Integer): Boolean;
begin
  Result := DataType in [fldINT16, fldUINT16, fldINT32, fldFLOAT, fldBCD];
end;

function IsTemporal(DataType: Integer): Boolean;
begin
  Result := DataType in [fldDATE, fldTIME, fldTIMESTAMP];
end;

procedure NotSupported;
begin
  raise ENotSupported.Create(SNotSupported);
end;

const
  NumericLen    = 10;

function StrToEvalFunction(const Func: string): TEvalFunction;
begin
  if (CompareText(Func, 'SUM') = 0) then
    Result := efSum
  else if (CompareText(Func, 'MIN') = 0) then
    Result := efMin
  else if (CompareText(Func, 'MAX') = 0) then
    Result := efMax
  else if (CompareText(Func, 'AVG') = 0) then
    Result := efAvg
  else if (CompareText(Func, 'COUNT') = 0) then
    Result := efCount
  else if (CompareText(Func, 'COUNT(*)') = 0) then
    Result := efCount
  else if (CompareText(Func, 'UPPER') = 0) then
    Result := efUpper
  else if (CompareText(Func, 'LOWER') = 0) then
    Result := efLower
  else if (CompareText(Func, 'SUBSTRING') = 0) then
    Result := efSubString
  else if (CompareText(Func, 'TRIM') = 0) then
    Result := efTrim
  else if (CompareText(Func, 'TRIMLEFT') = 0) then
    Result := efTrimLeft
  else if (CompareText(Func, 'TRIMRIGHT') = 0) then
    Result := efTrimRight
  else if (CompareText(Func, 'YEAR') = 0) then
    Result := efYear
  else if (CompareText(Func, 'MONTH') = 0) then
    Result := efMonth
  else if (CompareText(Func, 'DAY') = 0) then
    Result := efDay
  else if (CompareText(Func, 'HOUR') = 0) then
    Result := efHour
  else if (CompareText(Func, 'MINUTE') = 0) then
    Result := efMinute
  else if (CompareText(Func, 'SECOND') = 0) then
    Result := efSecond
  else if (CompareText(Func, 'GETDATE') = 0) then
    Result := efGetDate
  else if (CompareText(Func, 'DATE') = 0) then
    Result := efDate
  else if (CompareText(Func, 'TIME') = 0) then
    Result := efTime
  else if (CompareText(Func, 'IIF') = 0) then
    Result := efIIF
  else
    Result := efUnknown;
end;

procedure PreferInteger(iFldType1, iFldLen1, iFldType2, iFldLen2: Integer;
  var iFldType, iFldLen: Integer);
begin
  if iFldType1 = fldINT32 then
  begin
    iFldType := iFldType1;
    iFldLen  := iFldLen1;
  end else begin
    iFldType := iFldType2;
    iFldLen  := iFldLen2;
  end
end;

procedure PreferNumeric(iFldType1, iFldLen1, iFldType2, iFldLen2: Integer;
  var iFldType, iFldLen: Integer);
begin
  if iFldType1 = fldFLOAT then
  begin
    iFldType := iFldType1;
    iFldLen  := iFldLen1;
  end else if iFldType2 = fldFLOAT then
  begin
    iFldType := iFldType2;
    iFldLen  := iFldLen2;
  end else
    PreferInteger(iFldType1, iFldLen1, iFldType2, iFldLen2,  iFldType, iFldLen);
end;

procedure PreferString(iFldType1, iFldLen1, iFldType2, iFldLen2: Integer;
  var iFldType, iFldLen: Integer);
begin
  if iFldType1 = fldZSTRING then
  begin
    iFldType := fldZSTRING;
    if iFldType2 = fldZSTRING then
      iFldLen  := MaxInteger(iFldLen1, iFldLen2)
    else
      iFldLen  := MaxInteger(iFldLen1, NumericLen);
  end else if iFldType1 = fldZSTRING then
  begin
    iFldType := fldZSTRING;
    if iFldType1 = fldZSTRING then
      iFldLen  := MaxInteger(iFldLen1, iFldLen2)
    else
      iFldLen  := MaxInteger(iFldLen2, NumericLen);
  end else
    PreferNumeric(iFldType1, iFldLen1, iFldType2, iFldLen2,  iFldType, iFldLen);
end;

procedure CheckNotBCD(var Operand: Variant; var iFldType, iFldLen: Integer);
var
  Curr: Currency;
begin
  if (iFldType = fldBCD) then
  begin
    if not VarIsNull(Operand) then
    begin
      FMTBCDToCurr(pFMTBCD(TVarData(Operand).VString)^, Curr);
      Operand := Curr;
    end;
    iFldType := fldFLOAT;
    iFldLen  := SizeOf(Double);
  end;
end;

procedure CheckBCD(var Operand: Variant; var iFldType, iFldLen: Integer);
var
  Curr: Currency;
  BCD: FMTBCD;
  S: string;
begin
  if (iFldType <> fldBCD) then
  begin
    if not VarIsNull(Operand) then
    begin
      Curr := Operand;
      CurrToFMTBCD(Curr, BCD, 32, 18);
      SetString(S, PChar(@BCD), SizeOf(FMTBCD));
      Operand := S;
    end;
    iFldType := fldBCD;
    iFldLen  := SizeOf(FMTBCD);
  end;
end;

destructor Tvg2ExprEvaluator.Destroy;
begin
  FOpList := Unassigned;
  SetData(nil);
  inherited;
end;

procedure Tvg2ExprEvaluator.SetData(Value: PCanExpr);
begin
  ReallocMem(FExpr, 0);

  if Assigned(Value) then
  begin
    GetMem(FExpr, Value^.iTotalSize);
    Move(Value^, FExpr^, Value^.iTotalSize);
  end;
end;

function Tvg2ExprEvaluator.Evaluate(var iFldType, iFldLen: Integer): Variant;

  procedure SetResult(FldType, FldLen: Integer);
  begin
    iFldType := FldType;