frxxml.pas

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

{ 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
{$IFDEF Delphi12}
  Path: WideString;
  FileName: WideString;
{$ELSE}
  Path: String[64];
  FileName: String[255];
{$ENDIF}
begin
  if FTempFileCreated then Exit;
{$IFDEF Delphi12}
  SetLength(FileName, 255);
  Path := FTempDir;
  if (Path = '') or not DirectoryExists(String(Path)) then
  begin
    SetLength(Path, 255);
    SetLength(Path, GetTempPath(255, @Path[1]));
  end
  else
{$ELSE}
  Path := FTempDir;
  if (Path = '') or not DirectoryExists(Path) then
    Path[0] := Chr(GetTempPath(64, @Path[1])) else
{$ENDIF}
    Path := Path + #0;
  if (Path <> '') and (Path[Length(Path)] <> '\') then
    Path := Path + '\';

  GetTempFileName(@Path[1], PChar('fr'), 0, @FileName[1]);
{$IFDEF Delphi12}
  FTempFile := StrPas(PWideChar(@FileName[1]));
{$ELSE}
  FTempFile := StrPas(@FileName[1]);
{$ENDIF}
  FTempStream := TFileStream.Create(FTempFile, fmOpenReadWrite);
  FTempFileCreated := True;
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;
    FOldVersion := rd.FOldFormat;
    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 TfrxInvalidXMLException.Create('Invalid file format');
end;

procedure TfrxXMLReader.ReadHeader;
var
  s1, s2: String;
//{$IFDEF Delphi12}
  i: Integer;
  Ver: String;
//{$ENDIF}
begin
  ReadItem(s1, s2);
  if Pos('?xml', s1) <> 1 then
    RaiseException;
  i := Pos('version=', s2);
  if i <> 0 then
    Ver := Copy(s2, i + 9, 3);
  if Ver = '1.0' then
    FOldFormat := True;
//{$ELSE}
//  if Pos('?xml', s1) <> 1 then
//      RaiseException;
//{$ENDIF}
end;

procedure TfrxXMLReader.ReadItem(var {$IFDEF Delphi12}NameS{$ELSE}Name{$ENDIF}, Text: String);
var
  c: Integer;
  curpos, len: Integer;
  state: (FindLeft, FindRight, FindComment, Done);
  i, comment: Integer;
  ps: PAnsiChar;
{$IFDEF Delphi12}
  Name: AnsiString;
{$ENDIF}
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] := AnsiChar(Chr(c));
        Inc(curpos);
{$IFDEF Delphi12}
        if (curpos = 3) and (Pos(AnsiString('!--'), Name) = 1) then
{$ELSE}
        if (curpos = 3) and (Pos('!--', Name) = 1) then
{$ENDIF}
        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
        else
          comment := 0;
      end
      else begin
        if c = Ord('-') then
          Inc(comment)
        else
          comment := 0;
      end;
    end;
  end;

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

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

{$IFDEF Delphi12}
  i := Pos(AnsiString(' '), Name);
{$ELSE}
  i := Pos(' ', Name);
{$ENDIF}
  if i <> 0 then
  begin
{$IFDEF Delphi12}
if FOldFormat then
   Text := String(Copy(Name, i + 1, len - i)) else
   Text := UTF8Decode(Copy(Name, i + 1, len - i));
{$ELSE}
    Text := Copy(Name, i + 1, len - i);
{$ENDIF}
    Delete(Name, i, len - i + 1);
  end;
{$IFDEF Delphi12}
    NameS := String(Name);
{$ENDIF}
{    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;

{$IFDEF Delphi12}
//    if (LastName <> '') and (AnsiStrComp(PAnsiChar(LastName), PAnsiChar(AnsiString('/' + RootItem.Name))) <> 0) then
    if (LastName <> '') and (AnsiCompareText(LastName, '/' + RootItem.Name) <> 0) then
{$ELSE}
    if (LastName <> '') and (AnsiCompareText(LastName, '/' + RootItem.Name) <> 0) then
{$ENDIF}
      RaiseException;

{$IFDEF Delphi12}
//    n := Pos(' ld="0"', LowerCase(String(RootItem.Text)));
    n := Pos(' ld="0"', LowerCase(RootItem.Text));
{$ELSE}
    n := Pos(' ld="0"', LowerCase(RootItem.Text));
{$ENDIF}
    if n <> 0 then
      Delete(RootItem.FText, n, 7);
    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: AnsiString);
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
{$IFDEF Delphi12}
  WriteLn('<?xml version="1.1" encoding="utf-8"?>');
{$ELSE}
  WriteLn('<?xml version="1.0" encoding="utf-8"?>');
{$ENDIF}
end;

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

procedure TfrxXMLWriter.WriteItem(Item: TfrxXMLItem; Level: Integer = 0);
var
  s: AnsiString;
begin
  if (Item.FText <> '') or Item.FUnloadable then
  begin
{$IFDEF Delphi12}
    s := UTF8Encode(Item.FText);
{$ELSE}
    s := Item.FText;
{$ENDIF}
    if (s = '') or (s[1] <> ' ') then
      s := ' ' + s;
    if Item.FUnloadable then
      s := s + 'ld="0"';
  end
  else
    s := '';

  if Item.Count = 0 then
  begin
    if Item.Value = '' then
      s := s + '/>'
    else
{$IFDEF Delphi12}
      s := s + '>' + UTF8Encode(Item.Value) + '</' + AnsiString(Item.Name) + '>'
{$ELSE}
      s := s + '>' + Item.Value + '</' + Item.Name + '>'
{$ENDIF}
  end
  else
    s := s + '>';
  if not FAutoIndent then
    s := '<' + AnsiString(Item.Name) + s else
    s := Dup(Level) + '<' + AnsiString(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('</' + AnsiString(RootItem.Name) + '>') else
        WriteLn(Dup(Level) + '</' + AnsiString(RootItem.Name) + '>');

    if NeedClear then
      RootItem.Clear;
  end;

begin
  DoWrite(RootItem);
  FlushBuffer;
end;

end.



//