fs_xml.pas

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

  end;

begin
  Clear;
  if Item <> nil then
    DoAssign(Item, Self);
end;


{ TfsXMLDocument }

constructor TfsXMLDocument.Create;
begin
  FRoot := TfsXMLItem.Create;
end;

destructor TfsXMLDocument.Destroy;
begin
  FRoot.Free;
  inherited;
end;

procedure TfsXMLDocument.Clear;
begin
  FRoot.Clear;
end;

procedure TfsXMLDocument.LoadFromStream(Stream: TStream);
var
  rd: TfsXMLReader;
begin
  rd := TfsXMLReader.Create(Stream);
  try
    FRoot.Clear;
    rd.ReadHeader;
    rd.ReadRootItem(FRoot);
  finally
    rd.Free;
  end;
end;

procedure TfsXMLDocument.SaveToStream(Stream: TStream);
var
  wr: TfsXMLWriter;
begin
  wr := TfsXMLWriter.Create(Stream);
  wr.FAutoIndent := FAutoIndent;

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

procedure TfsXMLDocument.LoadFromFile(const FileName: String);
var
  s: TFileStream;
begin
  s := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    LoadFromStream(s);
  finally
    s.Free;
  end;
end;

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


{ TfsXMLReader }

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

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

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

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

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

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

procedure TfsXMLReader.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 TfsXMLReader.ReadRootItem(Item: TfsXMLItem);
var
  LastName: String;

  function DoRead(RootItem: TfsXMLItem): Boolean;
  var
    n: Integer;
    ChildItem: TfsXMLItem;
    Done: Boolean;
  begin
    Result := False;
    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 := TfsXMLItem.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;
  end;

begin
  DoRead(Item);
end;


{ TfsXMLWriter }

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

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

procedure TfsXMLWriter.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 TfsXMLWriter.WriteHeader;
begin
  WriteLn('<?xml version="1.0"?>');
end;

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

procedure TfsXMLWriter.WriteItem(Item: TfsXMLItem; Level: Integer = 0);
var
  s: String;
begin
  if Item.FText <> '' then
  begin
    s := Item.FText;
    if (s = '') or (s[1] <> ' ') then
      s := ' ' + s;
  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 TfsXMLWriter.WriteRootItem(RootItem: TfsXMLItem);

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

    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.