frxxml.pas

这个是功能强大的报表软件

{******************************************}
{                                          }
{             FastReport v4.0              }
{               XML document               }
{                                          }
{         Copyright (c) 1998-2008          }
{         by Alexander Tzyganenko,         }
{            Fast Reports Inc.             }
{                                          }
{******************************************}

unit frxXML;

interface

{$I frx.inc}

uses
  Windows, SysUtils, Classes
{$IFDEF Delphi6}
, Variants
{$ENDIF};


type
  TfrxInvalidXMLException = class(Exception);

  TfrxXMLItem = class(TObject)
  private
    FData: Pointer;              { optional item data }
    FHiOffset: Byte;             { hi-part of the offset }
    FItems: TList;               { subitems }
    FLoaded: Boolean;            { item is loaded, no need to call LoadItem }
    FLoOffset: Integer;          { lo-part of the offset }
    FModified: Boolean;          { item is modified (used by preview designer) }
    FName: String;               { item name }
    FParent: TfrxXMLItem;        { item parent }
    FText: String;               { item attributes }
    FUnloadable: Boolean;
    FValue: String;              { item value <item>Value</item> }
    function GetCount: Integer;
    function GetItems(Index: Integer): TfrxXMLItem;
    function GetOffset: Int64;
    procedure SetOffset(const Value: Int64);
    function GetProp(Index: String): String;
    procedure SetProp(Index: String; const Value: String);
  public
    constructor Create;
    destructor Destroy; override;
    procedure AddItem(Item: TfrxXMLItem);
    procedure Clear;
    procedure InsertItem(Index: Integer; Item: TfrxXMLItem);

    function Add: TfrxXMLItem;
    function Find(const Name: String): Integer;
    function FindItem(const Name: String): TfrxXMLItem;
    function IndexOf(Item: TfrxXMLItem): Integer;
    function PropExists(const Index: String): Boolean;
    function Root: TfrxXMLItem;
    procedure DeleteProp(const Index: String);

    property Count: Integer read GetCount;
    property Data: Pointer read FData write FData;
    property Items[Index: Integer]: TfrxXMLItem read GetItems; default;
    property Loaded: Boolean read FLoaded;
    property Modified: Boolean read FModified write FModified;
    property Name: String read FName write FName;
{ offset is the position of the item in the tempstream. This parameter is needed
  for dynamically loading large files. Items that can be loaded on-demand must
  have Unloadable = True (in run-time) or have 'ld="0"' parameter (in the file) }
    property Offset: Int64 read GetOffset write SetOffset;
    property Parent: TfrxXMLItem read FParent;
    property Prop[Index: String]: String read GetProp write SetProp;
    property Text: String read FText write FText;
    property Unloadable: Boolean read FUnloadable write FUnloadable;
    property Value: String read FValue write FValue;
  end;

  TfrxXMLDocument = class(TObject)
  private
    FAutoIndent: Boolean;        { use indents when writing document to a file }
    FRoot: TfrxXMLItem;          { root item }
    FTempDir: String;            { folder for temporary files }
    FTempFile: String;           { tempfile name }
    FTempStream: TStream;        { temp stream associated with tempfile }
    FTempFileCreated: Boolean;   { tempfile has been created - need to delete it }
    FOldVersion: Boolean;
    procedure CreateTempFile;
    procedure DeleteTempFile;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure LoadItem(Item: TfrxXMLItem);
    procedure UnloadItem(Item: TfrxXMLItem);
    procedure SaveToStream(Stream: TStream);
    procedure LoadFromStream(Stream: TStream; AllowPartialLoading: Boolean = False);
    procedure SaveToFile(const FileName: String);
    procedure LoadFromFile(const FileName: String);

    property AutoIndent: Boolean read FAutoIndent write FAutoIndent;
    property Root: TfrxXMLItem read FRoot;
    property TempDir: String read FTempDir write FTempDir;
    property OldVersion: Boolean read FOldVersion;
  end;

{ TfrxXMLReader and TfrxXMLWriter are doing actual read/write to the XML file.
  Read/write process is buffered. }

  TfrxXMLReader = class(TObject)
  private
    FBuffer: PAnsiChar;
    FBufPos: Integer;
    FBufEnd: Integer;
    FPosition: Int64;
    FSize: Int64;
    FStream: TStream;
    FOldFormat: Boolean;
    procedure SetPosition(const Value: Int64);
    procedure ReadBuffer;
    procedure ReadItem(var {$IFDEF Delphi12}NameS{$ELSE}Name{$ENDIF}, Text: String);
  public
    constructor Create(Stream: TStream);
    destructor Destroy; override;
    procedure RaiseException;
    procedure ReadHeader;
    procedure ReadRootItem(Item: TfrxXMLItem; ReadChildren: Boolean = True);
    property Position: Int64 read FPosition write SetPosition;
    property Size: Int64 read FSize;
  end;

  TfrxXMLWriter = class(TObject)
  private
    FAutoIndent: Boolean;
    FBuffer: AnsiString;
    FStream: TStream;
    FTempStream: TStream;
    procedure FlushBuffer;
    procedure WriteLn(const s: AnsiString);
    procedure WriteItem(Item: TfrxXMLItem; Level: Integer = 0);
  public
    constructor Create(Stream: TStream);
    procedure WriteHeader;
    procedure WriteRootItem(RootItem: TfrxXMLItem);
    property TempStream: TStream read FTempStream write FTempStream;
  end;


{ StrToXML changes '<', '>', '"', cr, lf symbols to its ascii codes }
function frxStrToXML(const s: String): String;

{ ValueToXML convert a value to the valid XML string }
function frxValueToXML(const Value: Variant): String;

{ XMLToStr is opposite to StrToXML function }
function frxXMLToStr(const s: String): String;



implementation

uses FileCtrl;


function frxStrToXML(const s: String): String;
const
  SpecChars = ['<', '>', '"', #10, #13, '&'];
var
  i, lenRes, resI, ch: Integer;
  pRes: PChar;

  procedure ReplaceChars(var s: String; i: Integer);
  begin
{$IFDEF Delphi12}
    Insert('#' + IntToStr(Ord(s[i])) + ';', s, i + 1);
{$ELSE}
    Insert('#' + IntToStr(Ord(s[i])) + ';', s, i + 1);
{$ENDIF}
    s[i] := '&';
  end;

begin
  lenRes := Length(s);

  if lenRes < 32 then
  begin
    Result := s;
    for i := lenRes downto 1 do
{$IFDEF Delphi12}
      if CharInSet(s[i], SpecChars) then
{$ELSE}
      if s[i] in SpecChars then
{$ENDIF}
        if s[i] <> '&' then
          ReplaceChars(Result, i)
        else
        begin
          if Copy(s, i + 1, 5) = 'quot;' then
          begin
            Delete(Result, i, 6);
            Insert('&#34;', Result, i);
          end;
        end;
    Exit;
  end;

  { speed optimized code }
  SetLength(Result, lenRes);
  pRes := PChar(Result) - 1;
  resI := 1;
  i := 1;

  while i <= Length(s) do
  begin
    if resI + 5 > lenRes then
    begin
      Inc(lenRes, 256);
      SetLength(Result, lenRes);
      pRes := PChar(Result) - 1;
    end;

{$IFDEF Delphi12}
    if CharInSet(s[i], SpecChars) then
{$ELSE}
    if s[i] in SpecChars then
{$ENDIF}
    begin
      if (s[i] = '&') and (i <= Length(s) - 5) and (s[i + 1] = 'q') and
        (s[i + 2] = 'u') and (s[i + 3] = 'o') and (s[i + 4] = 't') and (s[i + 5] = ';') then
      begin
        pRes[resI] := '&';
        pRes[resI + 1] := '#';
        pRes[resI + 2] := '3';
        pRes[resI + 3] := '4';
        pRes[resI + 4] := ';';
        Inc(resI, 4);
        Inc(i, 5);
      end
      else
      begin
        pRes[resI] := '&';
        pRes[resI + 1] := '#';

        ch := Ord(s[i]);
        if ch < 10 then
        begin
          pRes[resI + 2] := Char(Chr(ch + $30));
          Inc(resI, 3);
        end
        else if ch < 100 then
        begin
          pRes[resI + 2] := Char(Chr(ch div 10 + $30));
          pRes[resI + 3] := Char(Chr(ch mod 10 + $30));
          Inc(resI, 4);
        end
        else
        begin
          pRes[resI + 2] := Char(Chr(ch div 100 + $30));
          pRes[resI + 3] := Char(Chr(ch mod 100 div 10 + $30));
          pRes[resI + 4] := Char(Chr(ch mod 10 + $30));
          Inc(resI, 5);
        end;
        pRes[resI] := ';';
      end;
    end
    else
      pRes[resI] := s[i];
    Inc(resI);
    Inc(i);
  end;

  SetLength(Result, resI - 1);
end;

function frxXMLToStr(const s: String): String;
var
  i, j, h, n: Integer;
begin
{$IFDEF Delphi12}
  Result := s;
{$ELSE}
  Result := s;
{$ENDIF}
  i := 1;
  n := Length(s);
  while i < n do
  begin
    if Result[i] = '&' then
      if (i + 3 <= n) and (Result[i + 1] = '#') then
      begin
        j := i + 3;
        while Result[j] <> ';' do
          Inc(j);
{$IFDEF Delphi12}
        h := StrToInt(String(Copy(Result, i + 2, j - i - 2)));
{$ELSE}
        h := StrToInt(Copy(Result, i + 2, j - i - 2));
{$ENDIF}
        Delete(Result, i, j - i);
        Result[i] := Char(Chr(h));
        Dec(n, j - i);
      end
      else if Copy(Result, i + 1, 5) = 'quot;' then
      begin
        Delete(Result, i, 5);
        Result[i] := '"';
        Dec(n, 5);
      end
      else if Copy(Result, i + 1, 4) = 'amp;' then
      begin
        Delete(Result, i, 4);
        Result[i] := '&';
        Dec(n, 4);
      end
      else if Copy(Result, i + 1, 3) = 'lt;' then
      begin
        Delete(Result, i, 3);
        Result[i] := '<';
        Dec(n, 3);
      end
      else if Copy(Result, i + 1, 3) = 'gt;' then
      begin
        Delete(Result, i, 3);
        Result[i] := '>';
        Dec(n, 3);
      end;
    Inc(i);
  end;
end;

function frxValueToXML(const Value: Variant): String;
begin
  case TVarData(Value).VType of
    varSmallint, varInteger, varByte:
      Result := IntToStr(Value);

    varSingle, varDouble, varCurrency:
      Result := FloatToStr(Value);

    varDate:
      Result := DateToStr(Value);

    varOleStr, varString, varVariant{$IFDEF Delphi12}, varUString{$ENDIF}:
      Result := frxStrToXML(Value);

    varBoolean:
      if Value = True then Result := '1' else Result := '0';

    else
      Result := '';
  end;
end;

{ TfrxXMLItem }

constructor TfrxXMLItem.Create;
begin
  FLoaded := True;
end;

destructor TfrxXMLItem.Destroy;
begin
  Clear;
  if FParent <> nil then
    FParent.FItems.Remove(Self);
  inherited;
end;

procedure TfrxXMLItem.Clear;
begin
  if FItems <> nil then
  begin
    while FItems.Count > 0 do
      TfrxXMLItem(FItems[0]).Free;
    FItems.Free;
    FItems := nil;
  end;
  if FUnloadable then
    FLoaded := False;
end;

function TfrxXMLItem.GetItems(Index: Integer): TfrxXMLItem;
begin
  Result := TfrxXMLItem(FItems[Index]);
end;

function TfrxXMLItem.GetCount: Integer;
begin
  if FItems = nil then
    Result := 0 else
    Result := FItems.Count;
end;

function TfrxXMLItem.Add: TfrxXMLItem;
begin
  Result := TfrxXMLItem.Create;
  AddItem(Result);
end;

procedure TfrxXMLItem.AddItem(Item: TfrxXMLItem);
begin
  if FItems = nil then
    FItems := TList.Create;

  FItems.Add(Item);
  if Item.FParent <> nil then
    Item.FParent.FItems.Remove(Item);
  Item.FParent := Self;
end;

procedure TfrxXMLItem.InsertItem(Index: Integer; Item: TfrxXMLItem);
begin
  AddItem(Item);
  FItems.Delete(FItems.Count - 1);
  FItems.Insert(Index, Item);
end;

function TfrxXMLItem.Find(const Name: String): Integer;
var
  i: Integer;
begin
  Result := -1;
  for i := 0 to Count - 1 do
{$IFDEF Delphi12}
//    if AnsiStrComp(PAnsiChar(Items[i].Name), PAnsiChar(Name)) = 0 then
    if AnsiCompareText(Items[i].Name, Name) = 0 then
{$ELSE}
    if AnsiCompareText(Items[i].Name, Name) = 0 then
{$ENDIF}
    begin
      Result := i;
      break;
    end;
end;

function TfrxXMLItem.FindItem(const Name: String): TfrxXMLItem;
var
  i: Integer;
begin
  i := Find(Name);
  if i = -1 then
  begin
    Result := Add;
    Result.Name := Name;
  end
  else
    Result := Items[i];
end;

function TfrxXMLItem.GetOffset: Int64;
begin
  Result := Int64(FHiOffset) * $100000000 + Int64(FLoOffset);
end;

procedure TfrxXMLItem.SetOffset(const Value: Int64);
begin
  FHiOffset := Value div $100000000;
  FLoOffset := Value mod $100000000;
end;

function TfrxXMLItem.Root: TfrxXMLItem;
begin
  Result := Self;
  while Result.Parent <> nil do
    Result := Result.Parent;
end;

function TfrxXMLItem.GetProp(Index: String): String;
var
  i: Integer;
begin
{$IFDEF Delphi12}
  i := Pos(' ' + AnsiUppercase(Index) + '="', AnsiUppercase(' ' + FText));
{$ELSE}
  i := Pos(' ' + AnsiUppercase(Index) + '="', AnsiUppercase(' ' + FText));
{$ENDIF}
  if i <> 0 then
  begin
{$IFDEF Delphi12}
    Result := Copy(FText, i + Length(Index + '="'), MaxInt);
    Result := frxXMLToStr(Copy(Result, 1, Pos('"', Result) - 1));
{$ELSE}
    Result := Copy(FText, i + Length(String(Index) + '="'), MaxInt);
    Result := frxXMLToStr(Copy(Result, 1, Pos('"', Result) - 1));
{$ENDIF}
  end
  else
    Result := '';
end;

procedure TfrxXMLItem.SetProp(Index: String; const Value: String);
var
  i, j: Integer;
  s: String;
begin
{$IFDEF Delphi12}
  i := Pos(' ' + AnsiUppercase(Index) + '="', AnsiUppercase(' ' + FText));
{$ELSE}
  i := Pos(' ' + AnsiUppercase(Index) + '="', AnsiUppercase(' ' + FText));
{$ENDIF}
  if i <> 0 then
  begin
    j := i + Length(Index + '="');
    while (j <= Length(FText)) and (FText[j] <> '"') do
      Inc(j);
    Delete(FText, i, j - i + 1);
  end
  else
    i := Length(FText) + 1;

  s := Index + '="' + frxStrToXML(Value) + '"';
  if (i > 1) and (FText[i - 1] <> ' ') then
    s := ' ' + s;
  Insert(s, FText, i);
end;

function TfrxXMLItem.PropExists(const Index: String): Boolean;
begin
{$IFDEF Delphi12}
  Result := Pos(' ' + AnsiUppercase(String(Index)) + '="', ' ' + AnsiUppercase(String(FText))) > 0;
{$ELSE}
  Result := Pos(' ' + AnsiUppercase(Index) + '="', ' ' + AnsiUppercase(FText)) > 0;
{$ENDIF}
end;

procedure TfrxXMLItem.DeleteProp(const Index: String);
var
  i: Integer;
begin
{$IFDEF Delphi12}
  i := Pos(' ' + AnsiUppercase(String(Index)) + '="', ' ' + AnsiUppercase(String(FText)));
{$ELSE}
  i := Pos(' ' + AnsiUppercase(Index) + '="', ' ' + AnsiUppercase(FText));
{$ENDIF}
  if i > 0 then
  begin
    SetProp(Index, '');
    Delete(FText, i, Length(Index) + 4);
  end;
end;

function TfrxXMLItem.IndexOf(Item: TfrxXMLItem): Integer;
begin
  Result := FItems.IndexOf(Item);
end;