frxxml.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

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

unit frxXML;

interface

{$I frx.inc}

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

type
  TfrxXMLItem = class(TObject)
  private
    FData:Pointer; { optional item data }
    FLoaded:Boolean; { item is loaded, no need to call LoadItem }
    FModified:Boolean; { item is modified (used by preview designer) }
    FHiOffset:Byte; { hi-part of the offset }
    FItems:TList; { subitems }
    FLoOffset:Integer; { lo-part of the offset }
    FName:String; { item name }
    FParent:TfrxXMLItem; { item parent }
    FText:String; { item attributes }
    FUnloadable:Boolean; { item can be restored with XMLDoc.LoadItem }
    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;

    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;
  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 }
    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;
  end;

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

  TfrxXMLReader = class(TObject)
  private
    FBuffer:PChar;
    FBufPos:Integer;
    FBufEnd:Integer;
    FPosition:Int64;
    FSize:Int64;
    FStream:TStream;
    procedure SetPosition(const Value:Int64);
    procedure ReadBuffer;
    procedure ReadItem(var Name, 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:String;
    FStream:TStream;
    FTempStream:TStream;
    procedure FlushBuffer;
    procedure WriteLn(const s:String);
    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

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

  procedure ReplaceChars(var s:String; i:Integer);
  begin
    Insert('#'+IntToStr(Ord(s[i]))+';', s, i+1);
    s[i]:= '&';
  end;

begin
  Result:= s;
  for i:= Length(s) downto 1 do
    if s[i] in SpecChars then
      ReplaceChars(Result, i);
end;

function frxXMLToStr(const s:String):String;
var
  i, j, h, n:Integer;
begin
  Result:= s;

  i:= 1;
  n:= Length(s);
  while i < n do
  begin
    if i+3 <= n then
      if (Result[i] = '&') and (Result[i+1] = '#') then
      begin
        j:= i+3;
        while Result[j]<>';' do
          Inc(j);
        h:= StrToInt(Copy(Result, i+2, j-i-2));
        Delete(Result, i, j-i);
        Result[i]:= Chr(h);
        Dec(n, j-i);
      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:
      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
    if AnsiCompareText(Items[i].Name, Name) = 0 then
    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
  i:= Pos(' '+AnsiUppercase(Index)+'="', AnsiUppercase(' '+FText));
  if i<>0 then
  begin
    Result:= Copy(FText, i+Length(Index+'="'), MaxInt);
    Result:= frxXMLToStr(Copy(Result, 1, Pos('"', Result)-1));
  end
  else
    Result:= '';
end;

procedure TfrxXMLItem.SetProp(Index:String; const Value:String);
var
  i, j:Integer;
  s:String;
begin
  i:= Pos(' '+AnsiUppercase(Index)+'="', AnsiUppercase(' '+FText));
  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
  Result:= Pos(' '+AnsiUppercase(Index)+'="', ' '+AnsiUppercase(FText)) > 0;
end;

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

{ TfrxXMLDocument }

constructor TfrxXMLDocument.Create;
begin
  FRoot:= TfrxXMLItem.Create;
end;

destructor TfrxXMLDocument.Destroy;
begin
  DeleteTempFile;
  FRoot.Free;
  inherited;
end;

procedure TfrxXMLDocument.Clear;
begin
  FRoot.Clear;
  DeleteTempFile;
end;

procedure TfrxXMLDocument.CreateTempFile;
var
  Path:String[64];
  FileName:String[255];
begin
  if FTempFileCreated then Exit;

  Path:= FTempDir;
  if Path = '' then
    Path[0]:= Chr(GetTempPath(64, @Path[1])) else
    Path:= Path+#0;
  if (Path<>'') and (Path[Length(Path)]<>'\') then
    Path:= Path+'\';

  GetTempFileName(@Path[1], PChar('fr'), 0, @FileName[1]);
  FTempFile:= StrPas(@FileName[1]);
  FTempStream:= TFileStream.Create(FTempFile, fmOpenReadWrite);
  FTempFileCreated:= True;