unit XMLWriter;

interface

uses
  Classes, SysUtils;

type

  TXmlStandalone = (xsOmit, xsYes, xsNo);

  TXmlCloseTag = (xtNone, xtClose, xtSlashClose);

  TXMLWriter = class
  private
    FCapacity: LongInt;
    FLength: Integer;
    FBuffer: PChar;
    procedure Grow;
  public
    constructor Create(const Standalone: TXmlStandalone);
    destructor Destroy; override;
    procedure WriteValue(const Buffer: PChar);
    procedure OpenElement(const Name: PChar; const CloseTag: TXmlCloseTag);
    procedure WriteElement(const Name, Value: PChar);
    procedure WriteAttribute(const Name, Value: PChar; const CloseTag: TXmlCloseTag); overload;
    procedure WriteBuffer(const Buffer: PChar);
    procedure WriteChar(const Value: Char);
    procedure CloseElement(const Name: PChar);
  end; 

implementation

const

  cOpenTag       = '<';
  cCloseTag      = '>';
  cSlash         = '/';
  cOpenSlashTag  = '</';
  cSlashCloseTag = '/>';
  cSpace         = ' ';
  cEquality      = '=';
  cApostrophe    = '"';
  cEqualApos     = '="';
  cXml           = '<?xml version="1.0" encoding="UTF-8" standalone="%s" ?>';
  cStandalones   : array [TXmlStandalone] of string = ('omit', 'yes', 'no');

{ TXMLWriter }

constructor TXMLWriter.Create(const Standalone: TXmlStandalone);
begin
  FCapacity := 0;
  FLength := 0;

  Grow;
  // xml declarations
  WriteBuffer(PChar(Format(cXml, [cStandalones[Standalone]])));
end;

destructor TXMLWriter.Destroy;
begin
  if FCapacity > 0 then
    FreeMem(FBuffer);
  FBuffer := nil;
  inherited Destroy;
end;

procedure TXMLWriter.Grow;
var
  NewCapacity: Integer;
begin
  NewCapacity := FCapacity + $200;
  if FCapacity = 0 then
  begin
    GetMem(FBuffer, NewCapacity * SizeOf(Char))
  end
  else
  begin
    ReallocMem(FBuffer, NewCapacity * SizeOf(Char));
  end;
  FCapacity := NewCapacity;
end;

procedure TXMLWriter.OpenElement(const Name: PChar; const CloseTag: TXmlCloseTag);
begin
  // <
  WriteChar(cOpenTag);
  // name
  WriteBuffer(Name);
  // >
  case CloseTag of
    xtClose: WriteChar(cCloseTag);
    xtSlashClose: WriteBuffer(cSlashCloseTag);
  end;
end;

procedure TXMLWriter.CloseElement(const Name: PChar);
begin
  // </
  WriteBuffer(cOpenSlashTag);
  // name
  WriteBuffer(Name);
  // >
  WriteChar(cCloseTag);
end;


procedure TXMLWriter.WriteElement(const Name, Value: PChar);
begin
  OpenElement(Name, xtClose);
  if Value <> nil then
  begin
    // value
    WriteValue(Value);
    // </name>
    CloseElement(Name);
  end
  else
    // />
    WriteBuffer(cSlashCloseTag);
end;


procedure TXMLWriter.WriteAttribute(const Name, Value: PChar; const CloseTag: TXmlCloseTag);
begin
  // space
  WriteChar(cSpace);
  // name
  WriteBuffer(Name);
  // ="
  WriteBuffer(cEqualApos);
  // value
  WriteValue(Value);
  // "
  WriteChar(cApostrophe);
  // >
  case CloseTag of
    xtClose: WriteChar(cCloseTag);
    xtSlashClose: WriteBuffer(cSlashCloseTag);
  end;
end;


procedure TXMLWriter.WriteBuffer(const Buffer: PChar);
var
  P: PChar;
begin
  P := Buffer;  
  while P^ <> #0 do begin
    (FBuffer + FLength)^ := P^;
    Inc(FLength);
    if FLength >= FCapacity then
      Grow;
    Inc(P);
  end;
end;

procedure TXMLWriter.WriteChar(const Value: Char);
begin
  (FBuffer + FLength)^ := Value;
  Inc(FLength);
  if FLength >= FCapacity then
    Grow;
end;


procedure TXMLWriter.WriteValue(const Buffer: PChar);
const
   clt  = '%lt;';
   cgt  = '%gt;';
   cmp  = '&amp;';
   cqt  = '&quot;';
var
  P: PChar;
  n : Integer;
begin
  P := Buffer;
  while P^ <> #0 do
  begin
    case P^ of
      '<':
        begin
          WriteBuffer(clt);
          Inc(P);
        end;
      '>':
        begin
          WriteBuffer(cgt);
          Inc(P);
        end;
      '&':
        begin
          WriteBuffer(cmp);
          Inc(P);
        end;
      '"':
        begin
          WriteBuffer(cqt);
          Inc(P);
        end
    else
      begin
         (FBuffer + FLength)^ := P^;
         Inc(FLength);
         if FLength = FCapacity then
           Grow;
         Inc(P);
      end;
    end
  end;
end;

end.

unit XMLWriter;

interface

uses
  Classes, SysUtils;

type

  TXmlStandalone = (xsOmit, xsYes, xsNo);

  TXmlCloseTag = (xtNone, xtClose, xtSlashClose);

  TXMLWriter = class
  private
    FBuffer: PChar;
    FCursor: PChar;
    FLast: PChar;
    procedure MoveCursor(Delta: Integer);
    procedure Grow;
  public
    constructor Create(const Standalone: TXmlStandalone);
    destructor Destroy; override;
    procedure WriteValue(const pValue: PChar);
    procedure OpenElement(const pName: PChar; const CloseTag: TXmlCloseTag);
    procedure WriteElement(const pName, pValue: PChar);
    procedure WriteAttribute(const pName, pValue: PChar; const CloseTag: TXmlCloseTag); overload;
    procedure WriteBuffer(const pBuffer: PChar);
    procedure WriteChar(const pValue: Char);
    procedure CloseElement(const pName: PChar);
    procedure CloseDocument;
    procedure SaveToFile(const FileName: string);
    procedure SaveToStream(const Stream: TStream);
    property Buffer: PChar read FBuffer;
  end;

implementation

uses Math, Windows;

const

  cOpenTag: Char = '<';
  cCloseTag: Char = '>';
  cSlash: Char = '/';
  cOpenSlashTag: PChar = '</';
  cSlashCloseTag: PChar = '/>';
  cSpace: Char = ' ';
  cEquality: Char = '=';
  cApostrophe: Char = '"';
  cEqualApos: PChar = '="';
  clt: PChar = '%lt;';
  cgt: PChar = '%gt;';
  cmp: PChar = '&amp;';
  cqt: PChar = '&quot;';

  cXml = '<?xml version="1.0" encoding="UTF-8" standalone="%s" ?>';
  cStandalones: array [TXmlStandalone] of string = ('omit', 'yes', 'no');

  { TXMLWriter }

constructor TXMLWriter.Create(const Standalone: TXmlStandalone);
begin
  // init mem
  FBuffer := GlobalAllocPtr(HeapAllocFlags, $100);
  FCursor := FBuffer;
  FLast := FCursor + $100;

  // xml declarations
  WriteBuffer(PChar(Format(cXml, [cStandalones[Standalone]])));
end;

destructor TXMLWriter.Destroy;
begin
  GlobalFreePtr(FBuffer);
  FCursor := nil;
  FLast := nil;
  FBuffer := nil;
  inherited Destroy;
end;


procedure TXMLWriter.OpenElement(const pName: PChar;
  const CloseTag: TXmlCloseTag);
begin
  WriteChar(cOpenTag);
  WriteBuffer(pName);
  case CloseTag of
    xtClose:
      WriteChar(cCloseTag);
    xtSlashClose:
      WriteBuffer(cSlashCloseTag);
  end;
end;

procedure TXMLWriter.CloseElement(const pName: PChar);
begin
  WriteBuffer(cOpenSlashTag);
  WriteBuffer(pName);
  WriteChar(cCloseTag);
end;

procedure TXMLWriter.WriteElement(const pName, pValue: PChar);
begin
  OpenElement(pName, xtClose);
  if pValue <> nil then
  begin
    WriteValue(pValue);
    CloseElement(pName);
  end
  else
    WriteBuffer(cSlashCloseTag);
end;

procedure TXMLWriter.WriteAttribute(const pName, pValue: PChar;
  const CloseTag: TXmlCloseTag);
begin
  WriteChar(cSpace);
  WriteBuffer(pName);
  WriteBuffer(cEqualApos);
  WriteValue(pValue);
  WriteChar(cApostrophe);
  case CloseTag of
    xtClose:
      WriteChar(cCloseTag);
    xtSlashClose:
      WriteBuffer(cSlashCloseTag);
  end;
end;

procedure TXMLWriter.WriteBuffer(const pBuffer: PChar);
var
  P: PChar;
begin
  P := pBuffer;
  while P^ <> #0 do
  begin
    FCursor^ := P^;
    MoveCursor(1);
    Inc(P);
  end;
end;

procedure TXMLWriter.WriteChar(const pValue: Char);
begin
  FCursor^ := pValue;
  MoveCursor(1);
end;

procedure TXMLWriter.WriteValue(const pValue: PChar);
var
  P: PChar;
  n: Integer;
begin
  P := pValue;
  while P^ <> #0 do
  begin
    case P^ of
      '<':
        begin
          WriteBuffer(clt);
          Inc(P);
        end;
      '>':
        begin
          WriteBuffer(cgt);
          Inc(P);
        end;
      '&':
        begin
          WriteBuffer(cmp);
          Inc(P);
        end;
      '"':
        begin
          WriteBuffer(cqt);
          Inc(P);
        end
    else
      begin
        FCursor^ := P^;
        MoveCursor(1);
        Inc(P);
      end;
    end
  end;
end;


procedure TXMLWriter.Grow;
var
  Cursor, Capacity: Integer;
begin
  Cursor := LongInt(FCursor - FBuffer);
  Capacity := LongInt(FLast - FBuffer);
  Capacity := Capacity + (Capacity div 4);
  FBuffer := GlobalReallocPtr(FBuffer, Capacity, HeapAllocFlags);
  FLast := FBuffer + Capacity;
  FCursor := FBuffer + Cursor;
end;


procedure TXMLWriter.MoveCursor(Delta: Integer);
begin
  Inc(FCursor, Delta);
  if FCursor = FLast then
    Grow
end;

procedure TXMLWriter.SaveToFile(const FileName: string);
var
  FileStream: TFileStream;
begin
  FileStream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(FileStream);
  finally
    FileStream.Free;
  end;
end;

procedure TXMLWriter.SaveToStream(const Stream: TStream);
var
  DataString: UTF8String;
begin
  DataString := UTF8Encode(Buffer);
  Stream.Write(DataString[1], Length(DataString));
end;

procedure TXMLWriter.CloseDocument;
var
  Cursor: Integer;
  Capacity: Integer;
begin
  if FCursor < FLast then
  begin
    Cursor := LongInt(FCursor - FBuffer);
    Capacity := (Cursor + $1FFF) and not $1FFF;
    FBuffer := GlobalReallocPtr(FBuffer, Capacity, HeapAllocFlags);
    FLast := FBuffer + Capacity;
    FCursor := FBuffer + Cursor;
  end;
  FCursor^ := #0;
end;

end.

procedure TForm1.btn1Click(Sender: TObject);
var
  x : TXMLWriter;
  i, j : Integer;
  p : PChar;
  tc : Integer;
begin
  x := TXMLWriter.Create(xsYes);
  try
    tc := GetTickCount;

    x.OpenElement(c1, xtClose);
    for i := 0 to 850254 do
    begin
      x.OpenElement(c2, xtNone);
      x.WriteAttribute(c3, PChar(IntToStr(i)), xtClose);

      for j := 0 to 24 do
      begin
        x.OpenElement(c4, xtNone);
        x.WriteAttribute(c5, PChar(IntToStr(j)), xtClose);
        x.CloseElement(c4);
      end;

      x.CloseElement(c2);
    end;
    x.CloseElement(c1);
    x.CloseDocument;

    ShowMessage(IntToStr(GetTickCount - tc));

    x.SaveToFile('c:\test.xml');
  finally
    x.Free;
  end;
end;