frxxml.pas

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

end;

procedure TfrxXMLDocument.DeleteTempFile;
begin
  if FTempFileCreated then
  begin
    FTempStream.Free;
    FTempStream:= nil;
    DeleteFile(FTempFile);
    FTempFileCreated:= False;
  end;
  if FTempStream<>nil then
    FTempStream.Free;
  FTempStream:= nil;
end;

procedure TfrxXMLDocument.LoadItem(Item:TfrxXMLItem);
var
  rd:TfrxXMLReader;
  Text:String;
begin
  if (FTempStream = nil) or Item.FLoaded or not Item.FUnloadable then Exit;

  rd:= TfrxXMLReader.Create(FTempStream);
  try
    rd.Position:= Item.Offset;
    Text:= Item.Text;
    rd.ReadRootItem(Item);
    Item.Text:= Text;
    Item.FLoaded:= True;
  finally
    rd.Free;
  end;
end;

procedure TfrxXMLDocument.UnloadItem(Item:TfrxXMLItem);
var
  wr:TfrxXMLWriter;
begin
  if not Item.FLoaded or not Item.FUnloadable then Exit;

  CreateTempFile;
  FTempStream.Position:= FTempStream.Size;
  wr:= TfrxXMLWriter.Create(FTempStream);
  try
    Item.Offset:= FTempStream.Size;
    wr.WriteRootItem(Item);
    Item.Clear;
  finally
    wr.Free;
  end;
end;

procedure TfrxXMLDocument.LoadFromStream(Stream:TStream;
  AllowPartialLoading:Boolean = False);
var
  rd:TfrxXMLReader;
begin
  DeleteTempFile;

  rd:= TfrxXMLReader.Create(Stream);
  try
    FRoot.Clear;
    FRoot.Offset:= 0;
    rd.ReadHeader;
    rd.ReadRootItem(FRoot, not AllowPartialLoading);
  finally
    rd.Free;
  end;

  if AllowPartialLoading then
    FTempStream:= Stream else
    FTempStream:= nil;
end;

procedure TfrxXMLDocument.SaveToStream(Stream:TStream);
var
  wr:TfrxXMLWriter;
begin
  wr:= TfrxXMLWriter.Create(Stream);
  wr.TempStream:= FTempStream;
  wr.FAutoIndent:= FAutoIndent;

  try
    wr.WriteHeader;
    wr.WriteRootItem(FRoot);
  finally
    wr.Free;
  end;
end;

procedure TfrxXMLDocument.LoadFromFile(const FileName:String);
var
  s:TFileStream;
begin
  s:= TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  LoadFromStream(s, True);
end;

procedure TfrxXMLDocument.SaveToFile(const FileName:String);
var
  s:TFileStream;
begin
  s:= TFileStream.Create(FileName+'.tmp', fmCreate);
  try
    SaveToStream(s);
  finally
    s.Free;
  end;

  DeleteTempFile;
  DeleteFile(FileName);
  RenameFile(FileName+'.tmp', FileName);
  LoadFromFile(FileName);
end;

{ TfrxXMLReader }

constructor TfrxXMLReader.Create(Stream:TStream);
begin
  FStream:= Stream;
  FSize:= Stream.Size;
  FPosition:= Stream.Position;
  GetMem(FBuffer, 4096);
end;

destructor TfrxXMLReader.Destroy;
begin
  FreeMem(FBuffer, 4096);
  FStream.Position:= FPosition;
  inherited;
end;

procedure TfrxXMLReader.ReadBuffer;
begin
  FBufEnd:= FStream.Read(FBuffer^, 4096);
  FBufPos:= 0;
end;

procedure TfrxXMLReader.SetPosition(const Value:Int64);
begin
  FPosition:= Value;
  FStream.Position:= Value;
  FBufPos:= 0;
  FBufEnd:= 0;
end;

procedure TfrxXMLReader.RaiseException;
begin
  raise Exception.Create('Invalid file format');
end;

procedure TfrxXMLReader.ReadHeader;
var
  s1, s2:String;
begin
  ReadItem(s1, s2);
  if Pos('?xml', s1)<>1 then
    RaiseException;
end;

procedure TfrxXMLReader.ReadItem(var Name, Text:String);
var
  c:Integer;
  curpos, len:Integer;
  state:(FindLeft, FindRight, FindComment, Done);
  i, comment:Integer;
  ps:PChar;
begin
  Text:= '';
  comment:= 0;
  state:= FindLeft;
  curpos:= 0;
  len:= 4096;
  SetLength(Name, len);
  ps:= @Name[1];

  while FPosition < FSize do
  begin
    if FBufPos = FBufEnd then
      ReadBuffer;
    c:= Ord(FBuffer[FBufPos]);
    Inc(FBufPos);
    Inc(FPosition);

    if state = FindLeft then
    begin
      if c = Ord('<') then
        state:= FindRight
    end
    else if state = FindRight then
    begin
      if c = Ord('>') then
      begin
        state:= Done;
        break;
      end
      else if c = Ord('<') then
        RaiseException
      else
      begin
        ps[curpos]:= Chr(c);
        Inc(curpos);
        if (curpos = 3) and (Pos('!--', Name) = 1) then
        begin
          state:= FindComment;
          comment:= 0;
          curpos:= 0;
        end;
        if curpos >= len-1 then
        begin
          Inc(len, 4096);
          SetLength(Name, len);
          ps:= @Name[1];
        end;
      end;
    end
    else if State = FindComment then
    begin
      if comment = 2 then
      begin
        if c = Ord('>') then
          state:= FindLeft
      end
      else if c = Ord('-') then
        Inc(comment) else
        comment:= 0;
    end;
  end;

  len:= curpos;
  SetLength(Name, len);

  if state = FindRight then
    RaiseException;
  if (Name<>'') and (Name[len] = ' ') then
    SetLength(Name, len-1);

  i:= Pos(' ', Name);
  if i<>0 then
  begin
    Text:= Copy(Name, i+1, len-i);
    Delete(Name, i, len-i+1);
  end;
end;

procedure TfrxXMLReader.ReadRootItem(Item:TfrxXMLItem; ReadChildren:Boolean = True);
var
  LastName:String;

  function DoRead(RootItem:TfrxXMLItem):Boolean;
  var
    n:Integer;
    ChildItem:TfrxXMLItem;
    Done:Boolean;
    CurPos:Int64;
  begin
    Result:= False;
    CurPos:= Position;
    ReadItem(RootItem.FName, RootItem.FText);
    LastName:= RootItem.FName;

    if (RootItem.Name = '') or (RootItem.Name[1] = '/') then
    begin
      Result:= True;
      Exit;
    end;

    n:= Length(RootItem.Name);
    if RootItem.Name[n] = '/' then
    begin
      SetLength(RootItem.FName, n-1);
      Exit;
    end;

    n:= Length(RootItem.Text);
    if (n > 0) and (RootItem.Text[n] = '/') then
    begin
      SetLength(RootItem.FText, n-1);
      Exit;
    end;

    repeat
      ChildItem:= TfrxXMLItem.Create;
      Done:= DoRead(ChildItem);
      if not Done then
        RootItem.AddItem(ChildItem) else
        ChildItem.Free;
    until Done;

    if (LastName<>'') and (AnsiCompareText(LastName, '/'+RootItem.Name)<>0) then
      RaiseException;

    n:= Pos('ld="0"', LowerCase(RootItem.Text));
    if n<>0 then
      Delete(RootItem.FText, n, 6);
    if not ReadChildren and (n<>0) then
    begin
      RootItem.Clear;
      RootItem.Offset:= CurPos;
      RootItem.FUnloadable:= True;
      RootItem.FLoaded:= False;
    end;
  end;

begin
  DoRead(Item);
end;

{ TfrxXMLWriter }

constructor TfrxXMLWriter.Create(Stream:TStream);
begin
  FStream:= Stream;
end;

procedure TfrxXMLWriter.FlushBuffer;
begin
  if FBuffer<>'' then
    FStream.Write(FBuffer[1], Length(FBuffer));
  FBuffer:= '';
end;

procedure TfrxXMLWriter.WriteLn(const s:String);
begin
  if not FAutoIndent then
    Insert(s, FBuffer, MaxInt) else
    Insert(s+#13#10, FBuffer, MaxInt);
  if Length(FBuffer) > 4096 then
    FlushBuffer;
end;

procedure TfrxXMLWriter.WriteHeader;
begin
  WriteLn('<?xml version="1.0" encoding="utf-8"?>');
end;

function Dup(n:Integer):String;
begin
  SetLength(Result, n);
  FillChar(Result[1], n, ' ');
end;

procedure TfrxXMLWriter.WriteItem(Item:TfrxXMLItem; Level:Integer = 0);
var
  s:String;
begin
  if (Item.FText<>'') or Item.FUnloadable then
  begin
    s:= Item.FText;
    if (s = '') or (s[1]<>' ') then
      s:= ' '+s;
    if Item.FUnloadable then
      s:= s+'ld="0"';
  end
  else
    s:= '';

  if Item.Count = 0 then
    s:= s+'/>' else
    s:= s+'>';
  if not FAutoIndent then
    s:= '<'+Item.Name+s else
    s:= Dup(Level)+'<'+Item.Name+s;
  WriteLn(s);
end;

procedure TfrxXMLWriter.WriteRootItem(RootItem:TfrxXMLItem);

  procedure DoWrite(RootItem:TfrxXMLItem; Level:Integer = 0);
  var
    i:Integer;
    rd:TfrxXMLReader;
    NeedClear:Boolean;
  begin
    NeedClear:= False;
    if not FAutoIndent then
      Level:= 0;

    if (FTempStream<>nil) and RootItem.FUnloadable and not RootItem.FLoaded then
    begin
      rd:= TfrxXMLReader.Create(FTempStream);
      try
        rd.Position:= RootItem.Offset;
        rd.ReadRootItem(RootItem);
        NeedClear:= True;
      finally
        rd.Free;
      end;
    end;

    WriteItem(RootItem, Level);
    for i:= 0 to RootItem.Count-1 do
      DoWrite(RootItem[i], Level+2);
    if RootItem.Count > 0 then
      if not FAutoIndent then
        WriteLn('</'+RootItem.Name+'>') else
        WriteLn(Dup(Level)+'</'+RootItem.Name+'>');

    if NeedClear then
      RootItem.Clear;
  end;

begin
  DoWrite(RootItem);
  FlushBuffer;
end;

end.