zparser.~pas

控件名称：WINZEOS.ZIP 2002年08月03日 作者：CapellaDevelopment Zeos系列构件套件包含一组可直接存取Linux知名的免费数据库MySQL、Postgre

{ Get function handle }
function TZParser.GetFunc(FuncName: string): TParseFunc;
var
  I: Integer;
begin
  FuncName := AnsiUpperCase(FuncName);
  for I := 0 to FFuncCount-1 do
    if UpperCase(FFuncs[I].FuncName) = FuncName then
    begin
      Result := FFuncs[I].FuncPtr;
      Exit;
    end;
  Result := nil;
end;

{ Set new function handle }
procedure TZParser.SetFunc(FuncName: string; FuncPtr: TParseFunc);
var
  I: Integer;
begin
  I := 0;
  FuncName := AnsiUpperCase(FuncName);
  while I < FFuncCount do
  begin
    if FFuncs[I].FuncName = FuncName then
    begin
      if Assigned(FuncPtr) then
        FFuncs[i].FuncPtr := FuncPtr;
      Exit;
    end;
    Inc(I);
  end;
  if I >= MAX_PARSE_FUNCS then Exit;
  FFuncs[I].FuncName := FuncName;
  FFuncs[I].FuncPtr  := FuncPtr;
  Inc(FFuncCount);
end;

{ Convert types of two variant values }
function TZParser.ConvType(Value: Variant): Variant;
begin
  case VarType(Value) of
    varByte, varSmallint, varInteger:
      Result := VarAsType(Value, varInteger);
    varSingle, varDouble, varCurrency:
      Result := VarAsType(Value, varDouble);
    varDate:
      Result := DateTimeToSqlDate(Value);
    varOleStr, varString, varVariant:
      Result := VarAsType(Value, varString);
    varBoolean:
      Result := Value;
    varEmpty, varNull:
      Result := Null;
    else
      raise EParseException.Create(STypesMismatch);
  end;
end;

{ Convert types of two variant values }
procedure TZParser.CheckTypes(Value1: Variant; var Value2: Variant);
begin
  if (Value1 = Null) or (Value2 = Null) then Exit;
  case VarType(Value1) of
    varInteger:
      if VarType(Value2) = varString then
        Value2 := StrToFloatEx(Value2)
      else
        Value2 := VarAsType(Value2, varInteger);
    varString:
        Value2 := VarAsType(Value2, varString);
    varDouble:
      if VarType(Value2) = varString then
        Value2 := StrToFloatEx(Value2)
      else
        Value2 := VarAsType(Value2, varDouble);
    varBoolean:
      case VarType(Value2) of
        varInteger, varDouble:
          Value2 := (Value2 <> 0);
        varString:
          Value2 := (StrToFloatEx(Value2) <> 0);
        varBoolean:
        else
          raise EParseException.Create(STypesMismatch);
      end;
    else
      raise EParseException.Create(STypesMismatch);
  end;
end;

{ Calculate an equation }
function TZParser.Evalute: Variant;
var
  I: Integer;
  Value1, Value2, Sgn: Variant;
  Op: string;
  FuncPtr: TParseFunc;
begin
  FStackCount := 0;
  for I := 0 to FParseCount-1 do
  begin
    case FParseItems[I].ItemType of
      ptFunction:
        begin
          FuncPtr := GetFunc(FParseItems[I].ItemValue);
          if Assigned(FuncPtr) then
            Push(FuncPtr(Self))
          else
            raise EParseException.CreateFmt(SFuncNotFound,
              [FParseItems[I].ItemValue]);
        end;
      ptVariable:
        begin
          Value1 := GetVar(FParseItems[I].ItemValue);
          if VarType(Value1) = varEmpty then
            raise EParseException.CreateFmt(SVarNotFound,
              [FParseItems[I].ItemValue]);
          Push(Value1);
        end;
      ptFloat, ptInteger, ptString, ptBoolean:
        Push(FParseItems[I].ItemValue);
      ptDelim:
        begin
          Op := VarAsType(FParseItems[I].ItemValue, varString);

          if Op[1] in ['+','-','*','/','%'] then
          begin
            Value2 := Pop;
            Value1 := Pop;

            if (Value1 = Null) or (Value2 = Null) then
            begin
              Push(Null);
              Continue;
            end;

            CheckTypes(Value1, Value2);
            case Op[1] of
              '+': Push(Value1 + Value2);
              '-': Push(Value1 - Value2);
              '*': Push(Value1 * Value2);
              '/': Push(Value1 / Value2);
              '%': Push(Value1 mod Value2);
            end;
            Continue;
          end;

          if (Op = '=') or (Op = '<') or (Op = '>') then
          begin
            Value2 := Pop;
            Value1 := Pop;

            CheckTypes(Value1, Value2);
            case Op[1] of
              '=': Push(Value1 = Value2);
              '<': Push(Value1 < Value2);
              '>': Push(Value1 > Value2);
            end;
            Continue;
          end;

          if (Op = '>=') or (Op = '<=') or (Op = '<>') then
          begin
            Value2 := Pop;
            Value1 := Pop;

            CheckTypes(Value1, Value2);
            if Op = '>=' then Push(Value1 >= Value2);
            if Op = '<=' then Push(Value1 <= Value2);
            if Op = '<>' then Push(Value1 <> Value2);
            Continue;
          end;

          if (Op = tokAND) or (Op = tokOR) or (Op = tokXOR) then
          begin
            Value1 := Pop;
            Value2 := Pop;

            if (Value1 = Null) or (Value2 = Null) then
            begin
              Push(Null);
              Continue;
            end;

            if Op = tokAND then Push(Value1 and Value2);
            if Op = tokOR then  Push(Value1 or Value2);
            if Op = tokXOR then Push((not Value1 and Value2) or (Value1 and not Value2));
            Continue;
          end;

          if Op = '~' then
          begin
            Value1 := Pop;
            if Value1 <> Null then
              Push(-Value1)
            else Push(Null);
            Continue;
          end;

          if Op = tokNOT then
          begin
            Value1 := Pop;
            if Value1 <> Null then
            begin
              CheckTypes(True, Value1);
              Push(not Value1);
            end else
              Push(Null);
            Continue;
          end;

          if Op = '^' then
          begin
            Value2 := Pop;
            Value1 := Pop;

            if (Value1 = Null) or (Value2 = Null) then
            begin
              Push(Null);
              Continue;
            end;

            Value2 := VarAsType(Value2, varDouble);
            Value1 := VarAsType(Value1, varDouble);
            if (Value1 < 0) and ((Value2 mod 2) = 1) then Sgn := -1
            else Sgn := 1;
            Push(Sgn*Power(Abs(Value1),Value2));
            Continue;
          end;

          if Op = tokLIKE then
          begin
            Value2 := Pop;
            Value1 := Pop;

            if (Value1 = Null) or (Value2 = Null) then
            begin
              Push(Null);
              Continue;
            end;

            Value2 := VarAsType(Value2, varString);
            Value1 := VarAsType(Value1, varString);
            Push(IsMatch(Value2,Value1));
            Continue;
          end;

          if Op = tokSTARTING then
          begin
            Value2 := Pop;
            Value1 := Pop;

            if (Value1 = Null) or (Value2 = Null) then
            begin
              Push(Null);
              Continue;
            end;

            Value2 := VarAsType(Value2, varString);
            Value1 := VarAsType(Value1, varString);
            Push(Copy(LowerCase(Value1),1,Length(Value2)) = LowerCase(Value2));
            Continue;
          end;

          (*
          if Op = tokBETWEEN then
          begin
            Value3 := Pop;
            Value2 := Pop;
            Value1 := Pop;

            Push((Value1 >= Value2) or (Value1 <= Value3));
            Continue;
          end;
          *)

          raise EParseException.Create(SIncorOperate);
        end;
    end;
  end;

  Result := Pop;
  if FStackCount > 0 then
    raise EParseException.Create(SEvalError);
end;

{ Push value to stack }
procedure TZParser.Push(Value: Variant);
begin
  if FStackCount >= MAX_PARSE_STACK then
    raise EParseException.Create(SStackFull);
  FParseStack[FStackCount] := Value;
  Inc(FStackCount);
end;

{ Pop value from stack }
function TZParser.Pop: Variant;
begin
  if FStackCount = 0 then
    raise EParseException.Create(SStackEmpty);
  Dec(FStackCount);
  Result := FParseStack[FStackCount];
end;

{ Clear all variables and equation }
procedure TZParser.Clear;
begin
  FStackCount := 0;
  FParseCount := 0;
  FVarCount   := 0;
  FEquation   := '';
end;

{ Define function }
function TZParser.CheckFunc(var Buffer: string): Boolean;
var
  I: Integer;
  Token: string;
begin
  I := 1;
  Result := False;
  while (I <= Length(Buffer)) and (Buffer[I] in [' ',#9,#10,#13]) do
    Inc(I);
  if Buffer = '' then
    Exit;
  if Buffer[I] = '(' then
  begin
    Result := True;
    ExtractToken(Buffer, Token);
  end;
end;

{************** User functions implementation **************}

{ Get current date and time }
function FuncNow(Sender: TZParser): Variant;
begin
  Result := Sender.Pop;
  if Result <> 0 then
    EParseException.CreateFmt(SIncorFuncParam,[tokNOW]);
  //Result := FormatDateTime('yyyy-mm-dd hh:nn:ss', Now()); //???
  {Format is different for other country}
  //Result := FormatDateTime(LongDateFormat+' '+LongTimeFormat, Now());
  Result := DateTimeToStr(Now());
end;

{ Get maximum value }
function FuncMax(Sender: TZParser): Variant;
var
  Count: Integer;
  Temp:  Variant;
begin
  Count := Sender.Pop;
  if Count = 0 then
    EParseException.CreateFmt(SIncorFuncParam,[tokMAX]);
  Result := Sender.Pop;
  Dec(Count);
  while Count > 0 do
  begin
    Temp := Sender.Pop;
    if Temp > Result then Result := Temp;
    Dec(Count);
  end;
end;

{ Get minimum value }
function FuncMin(Sender: TZParser): Variant;
var
  Count: Integer;
  Temp:  Variant;
begin
  Count := Sender.Pop;
  if Count = 0 then
    EParseException.CreateFmt(SIncorFuncParam,[tokMIN]);
  Result := Sender.Pop;
  Dec(Count);
  while Count > 0 do
  begin
    Temp := Sender.Pop;
    if Temp < Result then Result := Temp;
    Dec(Count);
  end;
end;

{ Calculate sum of values }
function FuncSum(Sender: TZParser): Variant;
var
  Count: Integer;
begin
  Count := Sender.Pop;
  if Count = 0 then
    EParseException.CreateFmt(SIncorFuncParam,[tokSUM]);
  Result := Sender.Pop;
  Dec(Count);
  while Count > 0 do
  begin
    Result := Result + Sender.Pop;
    Dec(Count);
  end;
end;

{ Get result by value }
function FuncIIf(Sender: TZParser): Variant;
var
  Count: Integer;
  Temp, Temp1, Temp2: Variant;
begin
  Count := Sender.Pop;
  if Count <> 3 then
    EParseException.CreateFmt(SIncorFuncParam,[tokIIF]);
  Temp2 := Sender.Pop;
  Temp1 := Sender.Pop;
  Temp := VarAsType(Sender.Pop, varBoolean);
  if Temp then Result := Temp1
  else Result := Temp2;
end;

{ Evalue sinus value }
function FuncSin(Sender: TZParser): Variant;
begin
  Result := Sender.Pop;
  if Result <> 1 then
    EParseException.CreateFmt(SIncorFuncParam,[tokSIN]);
  Result := Sin(Sender.Pop);
end;

{ Evalue cosinus value }
function FuncCos(Sender: TZParser): Variant;
begin
  Result := Sender.Pop;
  if Result <> 1 then
    EParseException.CreateFmt(SIncorFuncParam,[tokCOS]);
  Result := Cos(Sender.Pop);
end;

{ Evalue tangens value }
function FuncTan(Sender: TZParser): Variant;
begin
  Result := Sender.Pop;
  if Result <> 1 then
    EParseException.CreateFmt(SIncorFuncParam,[tokTAN]);
  Result := Tan(Sender.Pop);
end;

{ Evalue exponent value }
function FuncExp(Sender: TZParser): Variant;
begin
  Result := Sender.Pop;
  if Result <> 1 then
    EParseException.CreateFmt(SIncorFuncParam,[tokEXP]);
  Result := Exp(Sender.Pop);
end;

{ Evalue natural logoriphm value }
function FuncLn(Sender: TZParser): Variant;
begin
  Result := Sender.Pop;
  if Result <> 1 then
    EParseException.CreateFmt(SIncorFuncParam,[tokLN]);
  Result := Ln(Sender.Pop);
end;

{ Evalue square root value }
function FuncSqrt(Sender: TZParser): Variant;
begin
  Result := Sender.Pop;
  if Result <> 1 then
    EParseException.CreateFmt(SIncorFuncParam,[tokSQRT]);
  Result := Sqrt(Sender.Pop);
end;

{ Evalute absolute value }
function FuncAbs(Sender: TZParser): Variant;
begin
  Result := Sender.Pop;
  if Result <> 1 then
    EParseException.CreateFmt(SIncorFuncParam,[tokABS]);
  Result := Abs(Sender.Pop);
end;

{ Sql IN }
function FuncInList(Sender: TZParser): Variant;
var
  Count, I: Integer;
  Temp, Tempv: Variant;
begin
  Result := False;
  Count := Sender.Pop;
  if Count <3 then
    EParseException.CreateFmt(SIncorFuncParam,[tokINLIST]);

  Tempv := VarArrayCreate([0, Count-1], varVariant);

  for I := 1 to Count-1 do
  Tempv[I] := Sender.Pop;

  Temp := Sender.Pop;

  for I := 1 to Count - 1 do
  begin
    if Tempv[I]= Temp then
    begin
      Result := True;
      Break;
    end;
  end;
end;

{ Sql Between function }
function FuncBetween(Sender: TZParser): Variant;
var
  Count: Integer;
  Temp, Temp1, Temp2: Variant;
begin
  Count := Sender.Pop;
  if Count <> 3 then
    EParseException.CreateFmt(SIncorFuncParam,[tokBETWEEN]);

  Temp2 := Sender.Pop;
  Temp1 := Sender.Pop;
  Temp  := Sender.Pop;

  Result := (Temp >= Temp1) and (Temp <= Temp2);
end;

end.