uxlsencodeformula.pas

来自「delphi 第三方控件很出色,表格制作的」· PAS 代码 · 共 956 行 · 第 1/2 页

unit UXlsEncodeFormula;
{$IFDEF LINUX}{$INCLUDE ../FLXCOMPILER.INC}{$ELSE}{$INCLUDE ..\FLXCOMPILER.INC}{$ENDIF}

interface

uses
  XlsFormulaMessages, XlsMessages, UXlsFormulaParser,
  UFlxStack, UXlsStrings, SysUtils, UXlsBaseRecordLists, UXlsRowColEntries;

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

    FNameTable: TNameRecordList;
    FCellList: TCellList;

    StackWs: TWhiteSpaceStack;
    RefMode: TFmReturnType;
    RefModeNesting: integer;

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

    function NextChar: boolean;
    function PeekChar(var c: WideChar): boolean;
    function Peek2Char(var c: WideChar): boolean;
    function PeekCharWs(var c: WideChar): boolean;

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

    procedure GetFormulaArgs(const Index: integer; var ArgCount: integer);
    procedure GetFormula(const s: string);
    function  GetBool(const s: string): boolean;
    function IsErrorCode(const s: widestring; var b: byte): boolean;
    procedure GetError;
    procedure GetOneReference(var RowAbs, ColAbs: boolean;var Row, Col: integer);
    function  GetReference: 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: widestring);
    procedure GetQuotedRef3d;
    procedure GetRef3d(const s: widestring);
    function GetExternSheet(const ExternSheet: widestring): word;
  public
    constructor Create(const aw: widestring; const aNameTable: TNameRecordList; const aCellList: TCellList);
    destructor Destroy; override;
    procedure Parse;

    function TotalSize: integer;
    procedure CopyToPtr(const Ptr: PArrayOfByte; const aPos: 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: widestring; const aNameTable: TNameRecordList; const aCellList: TCellList);
begin
  inherited Create;
  Fw:= aw;
  ParsePos:=1;
  StackWs:=TWhiteSpaceStack.Create;
  FNameTable:=aNameTable;
  FCellList:=aCellList;
  RefMode:=fmValue;
  RefModeNesting:=0;
  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;

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

procedure TParseString.GetRef3d(const s: widestring);
var
  c: WideChar;
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: WideChar;
  d: WideChar;
  More: Boolean;
  sq: widestring;
  c: WideChar;
  s: widestring;
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: widechar;
begin
  if PeekCharWs(c) then
  begin
    if ord(c)>255 then raise Exception.CreateFmt(ErrUnexpectedChar, [char(c), ParsePos, Fw]);
    if IsNumber(c) then GetNumber else
    if c= fmOpenParen then
    begin
      SkipWhiteSpace;
      NextChar;
      Expression;
      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 then
      if IsAlpha(c) then GetAlpha
      else if c=fmSingleQuote then GetQuotedRef3d();
  end
  else
    raise Exception.CreateFmt(ErrUnexpectedEof, [Fw]);
end;

procedure TParseString.RefTerm;
// Factor [ : | ' ' | , Factor]
var
  c: widechar;
  b: byte;
begin
  Factor;
  //Pending: see how to fix intersect (on popwhitespace, if there are two references, is an intersect).
  while PeekCharWS(c) and ({(c=fmUnion) or }(c=fmRangeSep) {or (c=fmIntersect)}) do
  begin
    SkipWhiteSpace;
    NextChar;
    Factor;
    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: widechar;
  i, Negs: integer;
begin
  Negs:=0;
  while PeekCharWs(c) and (c=fmMinus) do
  begin
    SkipWhiteSpace;
    NextChar;
    inc(Negs);
  end;
  RefTerm;
  for i:=1 to Negs do AddParsed([ptgUminus]);
end;

procedure TParseString.PerTerm;
// NegTerm [%]*
var
  c: widechar;
begin
  NegTerm;
  while PeekCharWs(c) and (c=fmPercent) do
  begin
    SkipWhiteSpace;
    NextChar;
    AddParsed([ptgPercent]);
  end;
end;

procedure TParseString.ExpTerm;
// PerTerm [ ^ PerTerm]*
var
  c: widechar;
begin
  PerTerm;
  while PeekCharWs(c) and (c=fmPower) do
  begin
    SkipWhiteSpace;
    NextChar;
    PerTerm;
    AddParsed([ptgPower]);
  end;
end;

procedure TParseString.MulTerm;
// ExpTerm [ *|/ ExpTerm ]*
var
  c: widechar;
begin
  ExpTerm;
  while PeekCharWs(c) and ((c=fmMul) or (c=fmDiv)) do
  begin
    SkipWhiteSpace;
    NextChar;
    ExpTerm;
    if (c=fmMul) then AddParsed([ptgMul]) else AddParsed([ptgDiv]);
  end;
end;

procedure TParseString.AddTerm;
// MulTerm [ +|- MulTerm]*
var
  c: widechar;
begin
  MulTerm;
  while PeekCharWs(c) and ((c=fmPlus) or (c=fmMinus)) do
  begin
    SkipWhiteSpace;
    NextChar;
    MulTerm;
    if (c=fmPlus) then AddParsed([ptgAdd]) else AddParsed([ptgSub]);
  end;
end;

procedure TParseString.AndTerm;
// AddTerm [ & AddTerm]*
var
  c: widechar;
begin
  AddTerm;
  while PeekCharWs(c) and (c=fmAnd) do
  begin
    SkipWhiteSpace;
    NextChar;
    AddTerm;
    AddParsed([ptgConcat]);
  end;
end;

function TParseString.FindComTerm(var Ptg: byte): boolean;
var
  c,d:widechar;
  s: widestring;
  One: boolean;
begin
  Result:= PeekCharWs(c) and ((c=fmEQ) or (c=fmLT) or (c=fmGT));
  if Result then
  begin
    One:=true;
    SkipWhiteSpace; //Already granted we will add a ptg
    NextChar;
    if PeekChar(d)and((d=fmEQ) or (d=fmGT)) then
    begin
      s:=c; s:=s+d; One:=False;
      if s = fmGE then begin; NextChar; Ptg:=ptgGE; end else
      if s = fmLE then begin; NextChar; Ptg:=ptgLE; end else
      if s = fmNE then begin; NextChar; Ptg:=ptgNE; end else
      One:=True;
    end;
    If One then
      if c= fmEQ then Ptg:=ptgEQ else
      if c= fmLT then Ptg:=ptgLT else
      if c= fmGT then Ptg:=ptgGT else
      raise Exception.Create(ErrInternal);
  end;
end;

procedure TParseString.ComTerm;
// AndTerm [ = | < | > | <= | >= | <>  AndTerm]*
var
  c: widechar;
  Ptg: byte;
begin
  AndTerm;
  while PeekCharWs(c) and FindComTerm(Ptg) do
  begin
    //no NextChar or SkipWhitespace here. It is added by FindComTerm
    AndTerm;
    AddParsed([Ptg]);
  end;
end;

procedure TParseString.Expression;
begin
  ComTerm;
end;

procedure TParseString.GetNumber;
var
  c: widechar;
  d: double;
  w: word;
  ab: array[0..7] of byte;
  start: integer;
begin
  SkipWhiteSpace;
  start:=ParsePos;
  while PeekChar(c) and (IsNumber(c)or (c=fmFormulaDecimal)) do NextChar;
  if PeekChar(c) and ((c='e')or (c='E')) then //numbers like 1e+23
  begin
    NextChar;
    if PeekChar(c) and ((c=fmPlus)or (c=fmMinus)) then NextChar;
    while PeekChar(c) and IsNumber(c) do NextChar; //no decimals allowed here
  end;

  d:=fmStrToFloat(copy(FW, start, ParsePos-Start));

  if (round(d)=d) and (d<=$FFFF)and (d>=0) then
  begin
    w:=round(d);
    AddParsed([ptgInt, lo(w), hi(w)]);
  end else
  begin
    move(d, ab[0], length(ab));
    AddParsed([ptgNum, ab[0], ab[1], ab[2], ab[3], ab[4], ab[5], ab[6], ab[7]]);
  end;
end;

procedure TParseString.GetString;
var
  c,d,e: widechar;
  s: widestring;
  Xs: TExcelString;
  St: array of byte;
  More: boolean;
begin
  s:='';
  SkipWhiteSpace;
  if not PeekChar(c) or (c<>fmStr) then raise Exception.Create(ErrNotAString);
  NextChar;

  repeat
    More:=false;
    if PeekChar(c) and (c<>fmStr) then
    begin
      s:=s+c;
      NextChar;
      More:=true;
    end
    else
    begin
      if PeekChar(d) and (d=fmStr) and Peek2Char(e) and (e=fmStr) then
      begin
        s:=s+fmStr;
        NextChar;
        NextChar;
        More:=true;
      end;
    end;
   until not more;

   if not PeekChar(c) then raise Exception.CreateFmt(ErrUnterminatedString,[Fw]);
   NextChar;

   Xs:=TExcelString.Create(1,s);
   try
     SetLength(St, Xs.TotalSize+1);
     St[0]:=ptgStr;
     Xs.CopyToPtr(PArrayOfByte(St),1);
     AddParsed(St);
   finally
     FreeAndNil(Xs);
   end; //finally
end;

procedure TParseString.GetAlpha;
// Possibilities:
{ 1 -> Formula - We know by the "(" at the end
  2 -> Boolean - We just see if text is "true" or "false"
  3 -> Error   - No, we already cached this
  4 -> Reference - Look if it is one of the strings between A1..IV65536 (and $A$1) As it might start with $, we don't look at it here.
  5 -> 3d Ref    - Search for a '!'  As it migh start with "'" we don't look at it here.
  6 -> Named Range - if it isn't anything else...
}
var
  Start: integer;
  s: string; //no need for widestring
  c: widechar;
begin
  SkipWhiteSpace;
  start:=ParsePos;
  while PeekChar(c) and ( IsAlpha(c) or IsNumber(c) or (c='.')or (c=':')) do NextChar;
  s:=UpperCase(copy(FW, start, ParsePos-Start));

  if PeekChar(c) and (c=fmOpenParen) then GetFormula(s) else
  if PeekChar(c) and (c=fmExternalRef) then GetRef3d(s) else
  if not GetBool(s) then
  raise Exception.CreateFmt(ErrUnexpectedId,[s,Fw]);


end;

function TParseString.GetBool(const s: string): boolean;
var
  b: byte;
begin
  if s=fmTrue then b:=1 else
  if s=fmFalse then b:=0 else
  begin
    Result:=false;
    exit;
  end;

  AddParsed([ptgBool, b]);