tmsuxlsencodeformula.pas

TMS Component Pack V5.0包含了超过 280 个为 Delphi 以及 C++Builder 设计的 TMS 生产控件

unit tmsUXlsEncodeFormula;
{$INCLUDE ..\FLXCOMPILER.INC}

interface

uses
  tmsXlsFormulaMessages, tmsXlsMessages, tmsUXlsFormulaParser,
  tmsUFlxStack, tmsUXlsStrings, SysUtils, tmsUXlsBaseRecordLists, tmsUXlsRowColEntries, tmsUFlxMessages;

type
  TParseString= class
  private
    ParsePos: integer;
    Fw: UTF16String;
    FParsedData: array of byte;
    FParsedArrayData: array of byte;
    MaxErrorLen: integer;
    DirectlyInFormula: UTF16String;

    LastRefOp: integer;

    FCellList: TCellList;

    StackWs: TWhiteSpaceStack;

    Default3DExternSheet: UTF16String;
    Force3d: boolean; //Named ranges
    InitialRefMode: TFmReturnType;

    function IsNumber(const c: UTF16Char): boolean;
    function IsAlpha(const c: UTF16Char): boolean;
    function IsAZ(const c: UTF16Char): boolean;
    function ATo1(const c: UTF16Char): integer;

    function NextChar: boolean;
    function PeekChar(out c: UTF16Char): boolean;
    function Peek2Char(out c: UTF16Char): boolean;
    function PeekCharWs(out c: UTF16Char): boolean;

    procedure GetNumber;
    procedure GetString;
    procedure GetAlpha;
    procedure GetArray;

    procedure GetFormulaArgs(const Index: integer; out ArgCount: integer);
    procedure GetFormula(const s: UTF16String);
    function  GetBool(const s: UTF16String): boolean;
    function IsErrorCode(const s: UTF16String; out b: byte): boolean;
    procedure GetError;
    procedure GetOneReference(out RowAbs, ColAbs: boolean;out Row, Col: integer; out IsFullRowRange: Boolean; out IsFullColRange: Boolean);
    function  GetReference(const OnlyPeek: boolean): boolean;

    procedure Factor;     // [Whitespace]* Function | Number | String | Cell Reference | 3d Ref | (Expression) | NamedRange | Boolean | Err | Array
    procedure RefTerm;    // Factor [ : | ' ' | , Factor]
    procedure NegTerm;    // [-]* RefTerm
    procedure PerTerm;    // NegTerm [%]*
    procedure ExpTerm;    // PerTerm [ ^ PerTerm]*
    procedure MulTerm;    // ExpTerm [ *|/ ExpTerm ]*
    procedure AddTerm;    // MulTerm [ +|- MulTerm]*
    procedure AndTerm;    // AddTerm [ & AddTerm]*
    procedure ComTerm;    // AndTerm [ = | < | > | <= | >= | <>  AndTerm]*
    procedure Expression;

    procedure SkipWhiteSpace;
    procedure UndoSkipWhiteSpace(const SaveParsePos: integer);
    procedure PopWhiteSpace;
    procedure AddParsed(const s: array of byte; const PopWs: boolean=true);
    procedure AddParsedArray(const s: array of byte);
    function FindComTerm(var Ptg: byte): boolean;
    procedure GetGeneric3dRef(const ExternSheet: UTF16String);
    procedure GetQuotedRef3d;
    procedure GetRef3d(const s: UTF16String);
    function GetExternSheet(const ExternSheet: UTF16String): word;
    procedure ConvertLastRefValueType(const RefMode: TFmReturnType);
    function GetLastRefOp: byte;
    class function GetPtgMode(const aptg: byte): TFmReturnType;
    procedure SetLastRefOp(const aptg: byte; const RefMode: TFmReturnType);
    procedure ConvertLastRefValueTypeOnce(const RefMode: TFmReturnType; var First: boolean);
    function IsDirectlyInFormula: boolean;
    procedure DiscardNormalWhiteSpace;
    procedure MakeLastWhitespaceNormal;
    function GetSecondAreaPart(const ExternSheet: UTF16String;
      const OnlyPeek: Boolean; Row1, Col1: Int32; const RowAbs1, ColAbs1,
      IsFullRowRange1, IsFullColRange1: Boolean): Boolean;
    procedure DoExternNamedRange(const ExternSheet: UTF16String);
    procedure AddParsedArea(const Rw1, Rw2, grBit1, grBit2: Int32);
    procedure AddParsed3dArea(const ExternSheet: UTF16String; const Rw1, Rw2,
      grBit1, grBit2: Int32);
    procedure AddParsed3dRef(const ExternSheet: UTF16String; const Rw1,
      grBit1: Int32);
    procedure AddParsedRef(const Rw1, grBit1: Int32);
    procedure AddParsedExternName(const ExternSheet, ExternName: UTF16String);
  public
    constructor Create(const aw: UTF16String; const aCellList: TCellList; const ReturnType: TFmReturnType);
    constructor CreateExt(const aw: UTF16String;
      const aCellList: TCellList;
      const aForce3D: Boolean; const aDefault3DExternSheet: UTF16String;
      const ReturnType: TFmReturnType);

    destructor Destroy; override;
    procedure Parse;

    function TotalSize: integer;
    procedure CopyToPtr(const Ptr: PArrayOfByte; const aPos: integer);
    procedure CopyToPtrNoLen(const Ptr: PArrayOfByte; const destIndex: integer);
  end;

implementation

function GetRealPtg(const PtgBase: word; const ReturnType: TFmReturnType): word;
begin
  case ReturnType of
    fmArray: Result:=PtgBase+$40;
    fmRef  : Result:=PtgBase;
    else     Result:=PtgBase+$20;
  end; //case
end;

{ TParseString }

constructor TParseString.Create(const aw: UTF16String; const aCellList: TCellList; const ReturnType: TFmReturnType);
begin
  inherited Create;
  Fw:= aw;
  ParsePos:=1;
  StackWs:=TWhiteSpaceStack.Create;
  FCellList:=aCellList;
  Force3D := false;
  InitialRefMode:=ReturnType;
  MaxErrorLen:=Length(fmErrNull);
  if MaxErrorLen<Length(  fmErrDiv0 ) then MaxErrorLen:=Length(fmErrDiv0 );
  if MaxErrorLen<Length(  fmErrValue) then MaxErrorLen:=Length(fmErrValue);
  if MaxErrorLen<Length(  fmErrRef  ) then MaxErrorLen:=Length(fmErrRef  );
  if MaxErrorLen<Length(  fmErrName ) then MaxErrorLen:=Length(fmErrName );
  if MaxErrorLen<Length(  fmErrNum  ) then MaxErrorLen:=Length(fmErrNum  );
  if MaxErrorLen<Length(  fmErrNA   ) then MaxErrorLen:=Length(fmErrNA   );
end;

constructor TParseString.CreateExt(const aw: UTF16String; const aCellList: TCellList;
                     const aForce3D: Boolean; const aDefault3DExternSheet: UTF16String; const ReturnType: TFmReturnType);
begin
  Create(aw, aCellList, ReturnType);
  Default3DExternSheet := aDefault3DExternSheet;
  Force3D := aForce3d;
end;

destructor TParseString.Destroy;
begin
  FreeAndNil(StackWs);
  inherited;
end;

function TParseString.GetLastRefOp: byte;
begin
  Result:= FParsedData[LastRefOp];
end;

procedure TParseString.SetLastRefOp(const aptg: byte; const RefMode: TFmReturnType);
var
  newptg: Byte;
begin
  newptg := Byte(aptg);
  if (Byte(aptg) and 96) <> 0 then
  begin
    case RefMode of
      fmRef:
          newptg := Byte((newptg and 159) or 32);
      fmValue:
          newptg := Byte((newptg and 159) or 64);
      fmArray:
          newptg := Byte(newptg or 96);
    end; //case
  end;
  FParsedData[LastRefOp] :=newptg;
end;

class function TParseString.GetPtgMode(const aptg: byte): TFmReturnType;
var
  PtgMode: TFmReturnType;
begin
  PtgMode := fmValue;
  if ((aptg = ptgRange) or (aptg = ptgIsect)) or (aptg = ptgUnion) then PtgMode := fmRef;

  case aptg and 96 of
    32:
      PtgMode := fmRef;
    96:
      PtgMode := fmArray;
  end; //case
  
  Result := PtgMode;
end;

procedure TParseString.ConvertLastRefValueType(const RefMode: TFmReturnType);
var
  aptg: byte;
  PtgMode: TFmReturnType;
begin
  if LastRefOp < 0 then
    raise Exception.Create(ErrInternal);
  
  aptg := GetLastRefOp;
  PtgMode := GetPtgMode(aptg);
  case RefMode of
    fmValue:
    begin
      if PtgMode <> fmArray then
        SetLastRefOp(aptg, fmValue);
    end;
    fmArray:
    begin
      SetLastRefOp(aptg, fmArray);
    end;
  end;
end;

procedure TParseString.ConvertLastRefValueTypeOnce(const RefMode: TFmReturnType; var First: boolean);
begin
  if (First) then ConvertLastRefValueType(RefMode);
  First:=false;
end;

procedure TParseString.GetRef3d(const s: UTF16String);
var
  c: UTF16Char;
begin
  c := ' ';
  if not PeekChar(c) or (c <> fmExternalRef) then
    raise Exception.CreateFmt(ErrUnexpectedChar, [c, ParsePos, Fw]);
  NextChar;
  GetGeneric3dRef(s);
end;

procedure TParseString.GetQuotedRef3d;
var
  e: UTF16Char;
  d: UTF16Char;
  More: Boolean;
  sq: UTF16String;
  c: UTF16Char;
  s: UTF16String;
begin
  SkipWhiteSpace;
  s := '';
  c := ' ';
  sq := fmSingleQuote;
  if not PeekChar(c) or (c <> sq) then
    raise Exception.CreateFmt(ErrUnexpectedChar, [c, ParsePos, Fw]);
  NextChar;

  repeat
    More := False;
    if PeekChar(c) and (c <> sq) then
    begin
      s:=s+c;
      NextChar;
      More := True;
    end
    else
    begin
      d := ' ';
      e := ' ';
      if PeekChar(d) and (d = sq) and Peek2Char(e) and (e = sq) then
      begin
        s:=s+sq;
        NextChar;
        NextChar;
        More := True;
      end;
    end;
  until not More;
  if not PeekChar(c) or (c <> sq) then
    raise Exception.CreateFmt(ErrUnterminatedString, [Fw]);
  NextChar;
  GetRef3d(s);
end;

procedure TParseString.Factor;
var
  c: UTF16Char;
begin
  if PeekCharWs(c) then
  begin
    if ord(c)>255 then raise Exception.CreateFmt(ErrUnexpectedChar, [AnsiChar(c), ParsePos, Fw]);
    if c= fmOpenParen then
    begin
      SkipWhiteSpace;
      NextChar;

			DirectlyInFormula := DirectlyInFormula + '0';
			try
        Expression;
      finally
				Delete(DirectlyInFormula, Length(DirectlyInFormula), 1);
      end;

      if not (PeekCharWs(c)) or (c<>fmCloseParen) then raise Exception.CreateFmt(ErrMissingParen, [Fw]);
      SkipWhiteSpace;
      NextChar;
      PopWhiteSpace;
      AddParsed([ptgParen]);
    end
    else if c=fmStr then GetString
    else if c=fmOpenArray then GetArray
    else if c=fmErrStart then GetError
    else if not GetReference(false) then
		  if (IsNumber(c)) then GetNumber //Is number must go after getreference, to handle things like =sum(1:2)
      else if IsAlpha(c) then GetAlpha
      else if c=fmSingleQuote then GetQuotedRef3d();
  end
  else
    raise Exception.CreateFmt(ErrUnexpectedEof, [Fw]);
end;

function TParseString.IsDirectlyInFormula: boolean;
begin
  if (Length(DirectlyInFormula) <=0) then Result:= false
  else
  begin
    Result := DirectlyInFormula[Length(DirectlyInFormula)]='1';
  end;
end;

procedure TParseString.RefTerm;
// Factor [ : | ' ' | , Factor]
var
  c: UTF16Char;
  b: byte;
  First: boolean;
begin
  First:=true;
  Factor;
  //Pending: see how to fix intersect (on popwhitespace, if there are two references, is an intersect).
  //Union is only valid if we are not inside a function. For example A2:A3,B5 is ok. But HLookup(0,A2:A3,B5,1, true) is not ok.

  while PeekCharWS(c) and (((c=fmUnion) and not IsDirectlyInFormula)   or (c=fmRangeSep) {or (c=fmIntersect)}) do
  begin
	  ConvertLastRefValueTypeOnce(fmRef, First);
    SkipWhiteSpace;
    NextChar;
    Factor;
	  ConvertLastRefValueType(fmRef);

    if (c=fmUnion) then b:=ptgUnion else
    if (c=fmRangeSep) then b:=ptgRange else
    if (c=fmIntersect) then b:=ptgIsect else
    raise Exception.Create(ErrInternal);
    AddParsed(b);
  end;
end;

procedure TParseString.NegTerm;
//[-]* RefTerm
var
  c: UTF16Char;
  i: integer;
  s: UTF16String;
begin
  s:='';
  while PeekCharWs(c) and ((c=fmMinus) or (c=fmPlus))do
  begin
    SkipWhiteSpace;
    NextChar;
    s:=s+c;
  end;
  RefTerm;
  if Length(s)>0 then
  begin
    ConvertLastRefValueType(fmValue);
    for i:=1 to Length(s) do
      if (s[i] = fmMinus) then AddParsed([ptgUminus]) else AddParsed([ptgUplus]);
  end;
end;

procedure TParseString.PerTerm;
// NegTerm [%]*
var
  c: UTF16Char;
  First: boolean;
begin
  First:=true;
  NegTerm;
  while PeekCharWs(c) and (c=fmPercent) do
  begin
	  ConvertLastRefValueTypeOnce(fmValue, First);
    SkipWhiteSpace;
    NextChar;
    AddParsed([ptgPercent]);
  end;
end;

procedure TParseString.ExpTerm;
// PerTerm [ ^ PerTerm]*
var
  c: UTF16Char;
  First: boolean;
begin
  First:=true;
  PerTerm;
  while PeekCharWs(c) and (c=fmPower) do
  begin
	  ConvertLastRefValueTypeOnce(fmValue, First);
    SkipWhiteSpace;
    NextChar;
    PerTerm;
	  ConvertLastRefValueType(fmValue);
    AddParsed([ptgPower]);
  end;
end;

procedure TParseString.MulTerm;
// ExpTerm [ *|/ ExpTerm ]*
var
  c: UTF16Char;
  First: boolean;
begin
  First:=true;
  ExpTerm;
  while PeekCharWs(c) and ((c=fmMul) or (c=fmDiv)) do
  begin
	  ConvertLastRefValueTypeOnce(fmValue, First);
    SkipWhiteSpace;
    NextChar;
    ExpTerm;
	  ConvertLastRefValueType(fmValue);
    if (c=fmMul) then AddParsed([ptgMul]) else AddParsed([ptgDiv]);
  end;
end;

procedure TParseString.AddTerm;
// MulTerm [ +|- MulTerm]*
var
  c: UTF16Char;
  First: boolean;
begin
  First:=true;
  MulTerm;
  while PeekCharWs(c) and ((c=fmPlus) or (c=fmMinus)) do
  begin
	  ConvertLastRefValueTypeOnce(fmValue, First);
    SkipWhiteSpace;
    NextChar;
    MulTerm;