vg2canexpr.pas

Midas.dll全部源码

    iFldLen  := FldLen;
  end;

begin
  DoBeginEvaluate;
  try
    if Assigned(FExpr) then
      Result := GetOperandValue(0, iFldType, iFldLen)
    else begin
      Result := Null;
      SetResult(fldUNKNOWN, 0);
    end;
  finally
    DoEndEvaluate;
  end;
end;

function Tvg2ExprEvaluator.CompareOperandsEx (var Op1: Variant;
  var Op2: Variant; CaseIns: Boolean;
  PartialLen: Word; CompareLike: Boolean): Integer;
var
  OpNull1, OpNull2: Boolean;
begin
  try
    OpNull1 := VarIsNull(Op1);
    OpNull2 := VarIsNull(Op2);

    if OpNull1 or OpNull2 then
    begin
      Result := ord(OpNull1 and OpNull2 and not CaseIns and not CompareLike and (PartialLen = 0));
      Exit;
    end;

    if CompareLike then   //like
    begin
      if CaseIns then
          Result := integer(ord(Like(AnsiUpperCase(Op1), AnsiUpperCase(Op2)))xor 1) and 127
      else
          Result := integer(ord(Like(Op1, Op2)) xor 1) and 127;  //一般用这个
    end else begin
      if CaseIns then
        if PartialLen = 0 then
          begin
              Result := AnsiStrIComp(PChar(string(Op1)), PChar(string(Op2)));    //wide字符定位  [loCaseInsensitive]
             { if Result<>0 then
                 if MatchesMask(string(Op1),string(Op2)) then
                    Result:=0
                 else
                     Result:=1;   }
          end
        else
          begin
               Result := AnsiStrLIComp(PChar(string(Op1)), PChar(string(Op2)), PartialLen);//[loPartialKey,loCaseInsensitive]
               if Result<>0 then
                 if MatchesMask(string(Op1),string(Op2)) then
                    Result:=0
                 else
                     Result:=1;
          end
      else
        if PartialLen = 0 then
           Result := CompareOperands(Op1, Op2)
        else
          begin
               Result := AnsiStrLComp(PChar(string(Op1)), PChar(string(Op2)), PartialLen); //定位 [loPartialKey]
               if Result<>0 then
                 if MatchesMask(AnsiUpperCase(string(Op1)),AnsiUpperCase(string(Op2))) then
                    Result:=0
                 else
                     Result:=1;
          end;
    end;
  except
    on EVariantError do Result := 1;
  end;
end;

function Tvg2ExprEvaluator.CompareOperandsEx2(var Op1, Op2: Variant; var iFldType1, iFldLen1, iFldType2, iFldLen2: Integer): Integer;
begin
  try
    if (iFldType1 = fldBCD) or (iFldType2 = fldBCD) then
    begin
      CheckBCD(Op1, iFldType1, iFldLen1);
      CheckBCD(Op2, iFldType2, iFldLen2);
      Result := CompareFMTBCD(pFMTBCD(TVarData(Op1).VString)^, pFMTBCD(TVarData(Op2).VString)^);
    end else
      Result := CompareOperands(Op1, Op2);
  except
    on EVariantError do Result := 1;
  end;
end;

function Tvg2ExprEvaluator.CompareOperands (Op1: Variant;
  Op2: Variant): Integer;
begin
  try
    if Op1 > Op2 then Result :=  1 else
    if Op1 < Op2 then Result := -1 else Result := 0;
  except
    on EVariantError do Result := 1;
  end;
end;

function Tvg2ExprEvaluator.Exists (var Op1: Variant;
  var Op2: Variant): Boolean;
var
  I: Integer;
begin
  for I := 0 to VarArrayHighBound(Op2, 1) do
    begin
          if CompareOperands(Op1 ,Op2[i]) = 0 then
          begin
            Result := True;
            Exit;
          end;
    end;
  Result := False;
end;

function Tvg2ExprEvaluator.GetOperandValue(Offset: Word; var iFldType, iFldLen: Integer): Variant;

var
  iFldType1, iFldType2, iFldLen1, iFldLen2: Integer;

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

var
  I: Integer;
  S: string;
  CanHdr: pCanHdr;
  BCD: FMTBCD;
  P: pFMTBCD;
  Op1, Op2: Variant;
  Func: TEvalFunction;
begin
CanHdr := pCanHdr(PChar(FExpr) + SizeOf(CanExpr) + Offset);
  case NODEClassEnum(CanHdr^.nodeClass) of
    nodeNULL:
      begin
        Result := Null;
        SetResult(fldUNKNOWN, 0);
      end;
    nodeUNARY:
        with pCanUnary(CanHdr)^ do
        case CANOpEnum(canOp) of
          canISBLANK,
          canNOTBLANK:
            begin
              Result := VarIsNull(GetOperandValue(iOperand1, iFldType1, iFldLen1)) xor (canOp = ord(canNOTBLANK));
              SetResult(fldBOOL, SizeOf(WordBool));
            end;
          canNOT:
            begin
              Result := not GetOperandValue(iOperand1, iFldType1, iFldLen1);
              SetResult(fldBOOL, SizeOf(WordBool));
            end;
        canMINUS:
            begin
              Op1 := GetOperandValue(iOperand1, iFldType1, iFldLen1);
              if iFldType1 = fldBCD then
              begin
                P := pFMTBCD(TVarData(Op1).VString);
                P.iSignSpecialPlaces := P.iSignSpecialPlaces xor $80;
                Result := Op1;
              end else
                Result := - GetOperandValue(iOperand1, iFldType1, iFldLen1);
              SetResult(iFldType1, iFldLen1);
            end;
          canUPPER:
            begin
              Op1 := GetOperandValue(iOperand1, iFldType1, iFldLen1);
              if VarIsNull(Op1) then
                Result := Null else Result := AnsiUpperCase(Op1);
              SetResult(iFldType1, iFldLen1);
            end;
          canLOWER:
            begin
              Op1 := GetOperandValue(iOperand1, iFldType1, iFldLen1);
              if VarIsNull(Op1) then
                Result := Null else Result := AnsiLowerCase(Op1);
              SetResult(iFldType1, iFldLen1);
            end;
        else
          NotSupported;
        end;
    nodeBINARY:
      with pCanBinary(CanHdr)^ do
      begin
        Op1 := GetOperandValue(iOperand1, iFldType1, iFldLen1);
        if canOp <> ord(canASSIGN) then
          Op2 := GetOperandValue(iOperand2, iFldType2, iFldLen2);
        case CANOpEnum(canOp) of
          canEQ,
          canNE:
            begin
              Result := ((VarIsNull(Op1) and VarIsNull(Op2)) or
                (CompareOperandsEx2(Op1, Op2, iFldType1, iFldLen1, iFldType2, iFldLen2) = 0)) xor (canOp = ord(canNE));
              SetResult(fldBOOL, SizeOf(WordBool));
            end;
          canGT:
            begin
              if not (VarIsNull(Op1) or VarIsNull(Op2)) then
                Result := CompareOperandsEx2(Op1, Op2, iFldType1, iFldLen1, iFldType2, iFldLen2) > 0 else
                Result := False;
              SetResult(fldBOOL, SizeOf(WordBool));
            end;
          canLT:
            begin
              if not (VarIsNull(Op1) or VarIsNull(Op2)) then
                Result := CompareOperandsEx2(Op1, Op2, iFldType1, iFldLen1, iFldType2, iFldLen2) < 0 else
                Result := False;
              SetResult(fldBOOL, SizeOf(WordBool));
            end;
          canGE:
            begin
              if not (VarIsNull(Op1) or VarIsNull(Op2)) then
                Result := CompareOperandsEx2(Op1, Op2, iFldType1, iFldLen1, iFldType2, iFldLen2) >= 0 else
                Result := False;
              SetResult(fldBOOL, SizeOf(WordBool));
            end;
          canLE:
            begin
              if not (VarIsNull(Op1) or VarIsNull(Op2)) then
                Result := CompareOperandsEx2(Op1, Op2, iFldType1, iFldLen1, iFldType2, iFldLen2) <= 0 else
                Result := False;
              SetResult(fldBOOL, SizeOf(WordBool));
            end;
          canAND:
            begin
              Result := Op1 and Op2;
              SetResult(fldBOOL, SizeOf(WordBool));
            end;
          canOR:
            begin
              Result := Op1 or Op2;
              SetResult(fldBOOL, SizeOf(WordBool));
            end;
          canADD:
            begin
              if (iFldType1 = fldBCD) or (iFldType2 = fldBCD) then
              begin
                CheckBCD(Op1, iFldType1, iFldLen1);
                CheckBCD(Op2, iFldType2, iFldLen2);
                BCD := AddFMTBCD(pFMTBCD(TVarData(Op1).VString)^, pFMTBCD(TVarData(Op2).VString)^);
                SetString(S, PChar(@BCD), SizeOf(FMTBCD));
                Result := S;
                SetResult(fldBCD, SizeOf(FMTBCD));
              end else begin
                CheckNotBCD(Op1, iFldType1, iFldLen1);
                CheckNotBCD(Op2, iFldType2, iFldLen2);
                PreferString(iFldType1, iFldLen1, iFldType2, iFldLen2, iFldType, iFldLen);
                if (iFldType1 = fldZSTRING) or (iFldType2 = fldZSTRING) then
                  Result := Concat(Op1, Op2)
                else
                  Result := Op1 + Op2;
                if iFldType = fldZSTRING then
                  iFldLen := iFldLen1 + iFldLen2;
              end;
            end;
          canSUB:
            begin
              if (iFldType1 = fldBCD) or (iFldType2 = fldBCD) then
              begin
                CheckBCD(Op1, iFldType1, iFldLen1);
                CheckBCD(Op2, iFldType2, iFldLen2);
                BCD := SubFMTBCD(pFMTBCD(TVarData(Op1).VString)^, pFMTBCD(TVarData(Op2).VString)^);
                SetString(S, PChar(@BCD), SizeOf(FMTBCD));
                Result := S;
                SetResult(fldBCD, SizeOf(FMTBCD));
              end else begin
                CheckNotBCD(Op1, iFldType1, iFldLen1);
                CheckNotBCD(Op2, iFldType2, iFldLen2);
                Result := Op1 - Op2;
                PreferNumeric(iFldType1, iFldLen1, iFldType2, iFldLen2, iFldType, iFldLen);
              end;
            end;
          canMUL:
            begin
              if (iFldType1 = fldBCD) or (iFldType2 = fldBCD) then
              begin
                CheckBCD(Op1, iFldType1, iFldLen1);
                CheckBCD(Op2, iFldType2, iFldLen2);
                BCD := MulFMTBCD(pFMTBCD(TVarData(Op1).VString)^, pFMTBCD(TVarData(Op2).VString)^);
                SetString(S, PChar(@BCD), SizeOf(FMTBCD));
                Result := S;
                SetResult(fldBCD, SizeOf(FMTBCD));
              end else begin
                CheckNotBCD(Op1, iFldType1, iFldLen1);
                CheckNotBCD(Op2, iFldType2, iFldLen2);
                Result := Op1 * Op2;
                PreferNumeric(iFldType1, iFldLen1, iFldType2, iFldLen2, iFldType, iFldLen);
              end;
            end;
          canDIV:
            begin
              if (iFldType1 = fldBCD) or (iFldType2 = fldBCD) then
              begin
                CheckBCD(Op1, iFldType1, iFldLen1);
                CheckBCD(Op2, iFldType2, iFldLen2);
                BCD := DivFMTBCD(pFMTBCD(TVarData(Op1).VString)^, pFMTBCD(TVarData(Op2).VString)^);
                SetString(S, PChar(@BCD), SizeOf(FMTBCD));
                Result := S;
                SetResult(fldBCD, SizeOf(FMTBCD));
              end else begin
                CheckNotBCD(Op1, iFldType1, iFldLen1);
                CheckNotBCD(Op2, iFldType2, iFldLen2);
                if VarIsNull(Op2) or (CompareOperands(Op2,0) = 0) then
                 Result := Null else Result := Op1 / Op2;
                SetResult(fldFLOAT, SizeOf(Double));
              end;
            end;
          canMOD:
            begin
              CheckNotBCD(Op1, iFldType1, iFldLen1);
              CheckNotBCD(Op2, iFldType2, iFldLen2);
              if VarIsNull(Op2) or (CompareOperands(Op2, 0) = 0) then
                Result := Null else Result := Op1 mod Op2;
              PreferInteger(iFldType1, iFldLen1, iFldType2, iFldLen2, iFldType, iFldLen);
            end;
          canREM:
            begin
              CheckNotBCD(Op1, iFldType1, iFldLen1);
              CheckNotBCD(Op2, iFldType2, iFldLen2);
              if VarIsNull(Op2) or (CompareOperands(Op2,0) = 0) then
                Result := Null else Result := Op1 - Op1 div Op2 * Op2;
              PreferInteger(iFldType1, iFldLen1, iFldType2, iFldLen2, iFldType, iFldLen);
            end;
          canMIN:
            begin
              CheckNotBCD(Op1, iFldType1, iFldLen1);
              CheckNotBCD(Op2, iFldType2, iFldLen2);
              if (CompareOperands(Op1,Op2) < 0) then
                Result := Op1 else Result := Op2;
              PreferNumeric(iFldType1, iFldLen1, iFldType2, iFldLen2, iFldType, iFldLen);
            end;
          canMAX:
            begin
              CheckNotBCD(Op1, iFldType1, iFldLen1);
              CheckNotBCD(Op2, iFldType2, iFldLen2);
              if (CompareOperands(Op1, Op2) > 0) then
                Result := Op1 else Result := Op2;
              PreferString(iFldType1, iFldLen1, iFldType2, iFldLen2, iFldType, iFldLen);
            end;
          canAVG:
            begin
              CheckNotBCD(Op1, iFldType1, iFldLen1);
              CheckNotBCD(Op2, iFldType2, iFldLen2);
              Result := (Op1 + Op2) / 2;
              SetResult(fldFLOAT, SizeOf(Double));
            end;
          canLIKE:
            begin
              Result :=(CompareOperandsEx(Op1, Op2, False, 0, True)=0);
              SetResult(fldBOOL, SizeOf(WordBool));
            end;
          canIN:
            begin
              CheckNotBCD(Op1, iFldType1, iFldLen1);
              CheckNotBCD(Op2, iFldType2, iFldLen2);
              Result := Exists(Op1, Op2);
              SetResult(fldBOOL, SizeOf(WordBool));
            end;
          canASSIGN:
            begin
              Result := Op1;
              SetResult(iFldType1, iFldLen1);
            end;
          else
            NotSupported;
        end;
      end;
    nodeCOMPARE:
      with pCanCompare(CanHdr)^ do
        case CANOpEnum(canOp) of
          canEQ,
          canNE,
          canLIKE:
            begin
                op1:=GetOperandValue(iOperand1, iFldType1, iFldLen1);
                op2:=GetOperandValue(iOperand2, iFldType2, iFldLen2);
               Result := (CompareOperandsEx(op1, op2,
                bCaseInsensitive, iPartialLen, canOp = ord(canLIKE)) = 0) xor (canOp = ord(canNE));
              SetResult(fldBOOL, SizeOf(WordBool));
            end;
        end;
    nodeFIELD:
      with pCanField(CanHdr)^ do
        Result := GetFieldValue(iFieldNum, iNameOffset, iFldType, iFldLen);
    nodeCONST:
      with pCanConst(CanHdr)^ do
        Result := GetConstantValue(iType, iSize, iOffset, iFldType, iFldLen);
    nodeCONTINUE:
      begin
        Result := True;
        SetResult(fldBOOL, SizeOf(WordBool));
      end;
    nodeLIST:
      begin
        with pCanList(CanHdr)^ do
          Result := GetOperandValue(iOffset, iFldType1, iFldLen1);
        SetResult(fldUNKNOWN, 0);
      end;
    nodeFUNC:
      with pCANFunc(CanHdr)^ do
      begin
        Func := StrToEvalFunction(GetConstantValue(fldZSTRING, 0, iNameOffset, iFldType1, iFldLen1));
        Result := GetFuncValue(Func, iElemOffset, iFldType, iFldLen);
      end;