tmsuxlssst.pas

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

unit tmsUXlsSST;
{$INCLUDE ..\FLXCOMPILER.INC}
//This is a unit to optimize the SST for a big number of strings.
//Optimizations:
  //We use records, no objects to store the strings (4 bytes of VMT per string and avoid calling create/destroy)
  //We don't use Widestrings or Strings to store them (8+6 bytes / string and avoid double allocation, one for the record and one for the string)
  //PENDING: Hash array to locate strings

interface
uses SysUtils, tmsXlsMessages, tmsUXlsBaseRecords,
     tmsUXlsOtherRecords, tmsUXlsStrings, Classes, tmsUFlxMessages,
     {$IFDEF FLX_GENERICS} Generics.Collections, {$ENDIF}
     tmsUOle2Impl;
type
  TExtraData=Packed Record
    Refs: word;
    AbsStreamPos: LongWord;
    RecordStreamPos: Word;
    PosInTable:LongWord;
  end;

  PExtraData=^TExtraData;

  TiSSTEntry   = integer;  //offset to the array
  PiSSTEntry   = PArrayOfByte;  //Pointer to internal calcs. Never store it, because MemData.Buffer can be realocated

  TMemSST=record
     UsedSize: integer;
     Buffer: Array of Byte;
  end;

  {$IFDEF FLX_GENERICS}
  TSST = class(TList<TiSSTEntry>)
  private
  {$ELSE}
  TSST = class (TList)
    {$INCLUDE TiSSTHdr.inc}
  {$ENDIF}

  private
    MemSST: TMemSST;
    procedure QuickSort(L, R: Integer);
    function SSTRecordSize: int64;
    function ExtSSTRecordSize: int64;
  public
    constructor Create;
    function Find(const s:PiSSTEntry; var Index: integer): boolean;
    procedure Load(const aSSTRecord: TSSTRecord);
    procedure SaveToStream(const DataStream: TOle2File);
    procedure WriteExtSST(const DataStream: TOle2File);
    function AddString(const s:UTF16String; const RTFRuns: TRTFRunList):integer;
    procedure Sort;
    function TotalSize: int64;
    procedure FixRefs;

    function GetEntry(const aEntry: TiSSTEntry): PiSSTEntry;
  end;

  TLabelSSTRecord= class(TCellRecord)
  private
    pSSTEntry: TiSSTEntry;
    SST: TSST;
    function GetAsString: UTF16String;
    procedure SetAsString(const Value: UTF16String);
    function GetAsRTF: UTF16String;
    procedure SetAsRTF(const Value: UTF16String);
    function GetAsRichString: TRichString;
    procedure SetAsRichString(const Value: TRichString);
  protected
    function GetValue: Variant; override;
    procedure SetValue(const Value: Variant); override;
    function DoCopyTo: TBaseRecord; override;
  public
    constructor Create(const aId: word; const aData: PArrayOfByte; const aDataSize: integer);override;
    constructor CreateFromData(const aRow, aCol, aXF: word; const aSST: TSST);

    procedure AttachToSST(const aSST: TSST);
    procedure SaveToStream(const Workbook: TOle2File); override;

    destructor Destroy;override;

    property AsString: UTF16String read GetAsString write SetAsString;
    property AsRichString: TRichString read GetAsRichString write SetAsRichString;
    property AsRTF: UTF16String read GetAsRTF write SetAsRTF;
  end;

  TLabelRecord=class(TCellRecord)
    function GetValue: Variant; override;
    //We dont implement writing to a label. All writing should go to a LabelSST
  end;

  TRStringRecord=class(TCellRecord)
  private
    function GetAsRichString: TRichString;
  public
    function GetValue: Variant; override;
    property AsRichString: TRichString read GetAsRichString;
    //We dont implement writing to a label. All writing should go to a LabelSST
  end;

implementation
{$IFNDEF FLX_GENERICS}
{$INCLUDE TiSSTImp.inc}
{$ENDIF}

const
  MemSSTDeltaSize=8096*1024; {4M}

type
  TRecordBuff= array [0..MaxRecordDataSize+4] of byte;
    
procedure CreateSSTEntryFromString(var MemSST: TMemSST; const s: UTF16String; const RTFRuns: TRTFRunList; var Entry: TiSSTEntry);
var
  OptionFlags: byte;
  Wide: byte;
  Lb, OldSize, Posi, i: integer;
  pEntry: PArrayOfByte;
begin
  if IsWide(s) then Wide := 1 else Wide:=0;
  OptionFlags := Wide;
  if Length(RTFRuns)>0 then OptionFlags:=OptionFlags or $8;

{  GetMem(Entry, SizeOf(TExtraData)+ //Extra data not to be saved
                SizeOf(Word) + // String Length
                SizeOf(byte) + // OptionsFlag
                Length(s)*(1+OptionFlags));
}
  OldSize:=MemSST.UsedSize;
  inc( MemSST.UsedSize, SizeOf(TExtraData)+ //Extra data not to be saved
                        SizeOf(Word) + // String Length
                        SizeOf(byte) + // OptionsFlag
                        Length(s)*(1+Wide));

  if Length(RTFRuns)>0 then
    inc( MemSST.UsedSize, Length(RTFRuns)*4+2 ); //RTF Info

  Lb:=Length(MemSST.Buffer);
  if MemSST.UsedSize>=Lb then
    SetLength(MemSST.Buffer, Lb+ MemSSTDeltaSize); //A string can't be longer than 8192 bytes;

  Entry:=OldSize;
  pEntry:=@MemSST.Buffer[Entry];
  PExtraData(pEntry).Refs:=0;
  PExtraData(pEntry).AbsStreamPos:=0;
  PExtraData(pEntry).RecordStreamPos:=0;
  PExtraData(pEntry).PosInTable:=0;

  SetWord(pEntry, SizeOf(TExtraData), Length(s));
  pEntry[2+SizeOf(TExtraData)]:=OptionFlags;

  Posi:=3+SizeOf(TExtraData);
  if Length(RTFRuns)>0 then
  begin
    SetWord(pEntry, Posi, Length(RTFRuns));
    inc(Posi,2);
  end;

  if Wide = 1 then
  begin
    System.Move(s[1], pEntry^[Posi], Length(s)*2);
    inc(Posi, Length(s)*2);
  end else
  begin
    System.Move(WideStringToStringNoCodePage(s)[1], pEntry^[Posi], Length(s));
    inc(Posi, Length(s));
  end;

  for i:=0 to Length(RTFRuns)-1 do
  begin
    SetWord(pEntry, Posi, RTFRuns[i].FirstChar);
    SetWord(pEntry, Posi+2, RTFRuns[i].FontIndex);
    Inc(Posi, 4);
  end;

end;

procedure CreateSSTEntryFromRecord(var MemSST: TMemSST; var aSSTRecord: TBaseRecord; var Ofs: integer; var Entry: TiSSTEntry);
var
  Xs: TExcelString;
  Lb, OldSize: integer;
  pEntry: PArrayOfByte;
begin
  Xs:=TExcelString.Create(2, aSSTRecord, Ofs); //Ok, we use TExcelString... This could be done without creating an object, but I don't think there is a difference
                                             // and it's complicated, because it has to handle all continues and char-widechar issues
  try
    {GetMem(Entry, SizeOf(TExtraData)+Xs.TotalSize);}
    OldSize:=MemSST.UsedSize;
    inc( MemSST.UsedSize, SizeOf(TExtraData)+Xs.TotalSize);

    Lb:=Length(MemSST.Buffer);
    if MemSST.UsedSize>=Lb then
      SetLength(MemSST.Buffer, Lb+ MemSSTDeltaSize); //A string can't be longer than 8192 bytes;

    Entry:=OldSize;
    pEntry:=@MemSST.Buffer[OldSize];

    PExtraData(pEntry).Refs:=0;
    PExtraData(pEntry).AbsStreamPos:=0;
    PExtraData(pEntry).RecordStreamPos:=0;
    PExtraData(pEntry).PosInTable:=0;
    Xs.CopyToPtr(pEntry, SizeOf(TExtraData));
  finally
    FreeAndNil(Xs);
  end;

end;

function SSTLength(const S: PiSSTEntry): int64;
var
  OptionFlags: byte;
  Ofs: integer;
begin
    Ofs:=0;
    OptionFlags:=S[2+SizeOf(TExtraData)];
    Result:=SizeOf(TExtraData)+
            2+ //Length
            SizeOf(OptionFlags);
    if OptionFlags and $1 = 0 then Result:=Result+GetWord(S, SizeOf(TExtraData))
        else Result:= Result+GetWord(S, SizeOf(TExtraData))*2;

    //Rich text
    if OptionFlags and $8 = $8 {HasRichText} then
    begin
      Result:=Result + 2+ 4* GetWord(S,3+SizeOf(TExtraData));
      Ofs:=2;
    end;

    //FarEast
    if OptionFlags and $4 = $4 {HasFarInfo} then
      Result:=Result+ 4 + GetLongWord(S, 3+SizeOf(TExtraData)+Ofs);
end;

{function SSTRealLength(const S: PiSSTEntry): int64;
begin
  Result:=SSTLength(S)-SizeOf(TExtraData);
end;
}

function CompareSSTEntry(const S1, S2: PiSSTEntry): integer;
var
  i:integer;
  L1, L2: integer;
begin
  Result:=0;
  L1:= SSTLength(S1);
  L2:= SSTLength(S2);
  if L1<L2 then Result:=-1 else if L1>L2 then Result:=1
  else
  for i:=SizeOf(TExtraData) to L1-1 do
  begin
    if S1[i]=S2[i] then continue
    else if S1[i]<S2[i] then Result:=-1 else Result:=1;
    exit;
  end;
end;

function CompareSSTEntries(Item1, Item2: Pointer): Integer;
begin
  CompareSSTEntries:= CompareSSTEntry(PiSSTEntry(Item1),PiSSTEntry(Item2));
end;


procedure AddSSTRef(const Entry: PiSSTEntry);
begin
  Inc(PExtraData(Entry).Refs);
end;

procedure DecSSTRef(const Entry: PiSSTEntry);
begin
  Dec(PExtraData(Entry).Refs);
end;

function SSTRefs(const Entry: PiSSTEntry): word;
begin
  Result:=PExtraData(Entry).Refs;
end;

procedure AddContinue (const DataStream: TOle2File; var Buffer: TRecordBuff; var BufferPos: integer; var BeginRecordPos: LongWord; var TotalSize: int64);
begin
	if DataStream<>nil then
  begin
	  SetWord(PArrayOfByte(@Buffer), 2, BufferPos - 4);  //Adapt the record size before writing it.
		DataStream.WriteMem(Buffer, BufferPos);

  	BeginRecordPos:=DataStream.Position;
    SetWord(PArrayOfByte(@Buffer), 0, xlr_CONTINUE);
 		Buffer[4]:=0; Buffer[5]:=0; //Clear the OptionFlags.
  end;

  inc(TotalSize, BufferPos);
  BufferPos:= 4;
end;

function Min(const a, b: integer): integer;
begin
  if a<b then Result:=a else Result:=b;
end;

procedure WriteArray(const DataToWrite: PArrayOfByte; const DataLength: integer; DataStream: TOle2File; var Buffer: TRecordBuff;
  var BufferPos: Integer; var BeginRecordPos: LongWord; var TotalSize: Int64);
var
  Chars: Integer;
  BytesLeft: Integer;
  StPos: Integer;
begin
  StPos := 0;
  while (StPos < DataLength) do
  begin
    BytesLeft := (Length(Buffer) - BufferPos) div 4 * 4; //A string can not be splitted between formatting runs.
    Chars := Min((DataLength - StPos), BytesLeft);
    System.Move(DataToWrite[StPos], Buffer[BufferPos], Chars);
    inc(BufferPos, Chars);
    inc(StPos, Chars);
    if (StPos < DataLength) then
      AddContinue(DataStream, Buffer, BufferPos, BeginRecordPos, TotalSize);
  end;
end;



procedure SaveSSTToStream(const Entry: PiSSTEntry; const DataStream: TOle2File;
          var BeginRecordPos: LongWord; var Buffer: TRecordBuff; var BufferPos: Integer;  var TotalSize: Int64);

var
  i: Integer;
  b: Byte;
  CanCompress: Boolean;
  CharsUncompressed: Integer;
  CharsCompressed: Integer;
  StPos: Integer;
  OpFlagsPos: Integer;
  BytesLeft: Integer;
  aLen: word;
  OptionFlags: byte;
  p: integer;
  FarEastLen: LongWord;
  RTFRuns: word;
  Data: PArrayOfByte;
  CharSize: integer;
begin
  //First, see if we can write the header of this string on the current record, or if we have to create a new one
  BytesLeft := (Length(Buffer) - BufferPos);
  if (BytesLeft < 32) then    //12 is really the required, but we play it safe. Anyway, starting a new continue does no harm.
  begin
    AddContinue(DataStream, Buffer, BufferPos, BeginRecordPos, TotalSize);
    BytesLeft := (Length(Buffer) - BufferPos);
  end;

  if (DataStream <> nil) then
  begin
    PExtraData(Entry).AbsStreamPos := (DataStream.Position + BufferPos);
    PExtraData(Entry).RecordStreamPos := PExtraData(Entry).AbsStreamPos - BeginRecordPos;
  end;

  Assert((BytesLeft >= 32));
  aLen:=GetWord(Entry, SizeOf(TExtraData));
  if (DataStream <> nil) then System.Move(aLen , Buffer[BufferPos], 2);
  inc(BufferPos,2);

  OpFlagsPos := BufferPos;
  OptionFlags:= Entry[2+SizeOf(TExtraData)];
  Buffer[BufferPos] := OptionFlags;
  inc(BufferPos);

  p:=3;
  if  OptionFlags and $8 = $8 then //HasRichText then
  begin
    RTFRuns:=GetWord(Entry,p+SizeOf(TExtraData));

    if (DataStream <> nil) then
    begin
      System.Move(RTFRuns , Buffer[BufferPos], 2);
    end;
    inc(p,2);
    inc(BufferPos, 2);
  end;

  if OptionFlags and $4 = $4 then //HasFarInfo then
  begin
    FarEastLen:=GetLongWord(Entry,p+SizeOf(TExtraData));
    if (DataStream <> nil) then
    begin
      System.Move(FarEastLen , Buffer[BufferPos], 4);
    end;
    inc(p,4);
    inc(BufferPos, 4);
  end;

	// Write the actual string. It might span multiple continues
  StPos := 0;
  Data:= PArrayOfByte(@Entry[p+SizeOf(TExtraData)]);
  CharSize:=(OptionFlags and 1)+1;
  while (StPos < aLen) do  //If aLen==0, we won't write this string.
  begin
    BytesLeft := (Length(Buffer) - BufferPos);

		//Find if we can compress the unicode on this part.
		//If the number of chars we can write using compressed is bigger or equal than using uncompressed, we compress...
    CharsCompressed := Min((aLen - StPos), BytesLeft);
    CharsUncompressed := Min((aLen - StPos), (BytesLeft div 2));
    if (CharSize <> 1) then              //if charsize=1, string is already compressed.
    begin
      for i:= 0 to CharsCompressed-1 do
      begin
        if (Data[(StPos*CharSize + i*2+1)] <> 0) then
        begin
          CharsCompressed := i;
          break;
        end;
      end;
    end;

    CanCompress := (CharsCompressed >= CharsUncompressed);
    if CanCompress then
    begin
      b := $FE;
      Buffer[OpFlagsPos] := Buffer[OpFlagsPos] and b;
      if (DataStream <> nil) then
      begin
        for i := 0 to CharsCompressed-1 do
        begin
           Buffer[BufferPos] := Data[(StPos + i)*CharSize];
           inc(BufferPos);
        end;
      end
        else inc(BufferPos, CharsCompressed);

      inc( StPos, CharsCompressed);

      if (StPos < aLen) then
      begin
        AddContinue(DataStream, Buffer, BufferPos, BeginRecordPos, TotalSize);
        OpFlagsPos := BufferPos;
        inc(BufferPos);
      end;
    end
      else
    begin
      b := 1;
      Buffer[OpFlagsPos] := Buffer[OpFlagsPos] or b;
      if (DataStream <> nil) then
      begin
        System.Move(Data[StPos*2], Buffer[BufferPos], 2*CharsUncompressed);
      end;

      inc (BufferPos, CharsUncompressed*2);
      inc (StPos, CharsUncompressed);

      if (StPos < aLen) then
      begin
        AddContinue(DataStream, Buffer, BufferPos, BeginRecordPos, TotalSize);
        OpFlagsPos := BufferPos;
        inc(BufferPos);
      end;
    end;
  end;

  inc(p, aLen*CharSize);

  if  OptionFlags and $8 = $8 then //HasRichText then
  begin
     Data:= PArrayOfByte(@Entry[p+SizeOf(TExtraData)]);
     WriteArray(Data, RTFRuns*4, DataStream, Buffer, BufferPos, BeginRecordPos, TotalSize);
     p:=p+RTFRuns*4;
  end;

  if OptionFlags and $4 = $4 then //HasFarInfo then