Sordie.co.uk

libsassy/libSassy.XML.pas

Raw

{(
 )) libSassy.XML
((    Extensible Markup Language library
 ))
((  Copyright  Sordie Aranka Solomon-Smith 2015-2016
 ))
((  This work is made available under the terms of the Creative Commons
 )) Attribution-NonCommercial-ShareAlike 3.0 Unported license
((  http://creativecommons.org/licenses/by-nc-sa/3.0/
 )}

unit libSassy.XML;

interface

uses
  libSassy.Interfaces,
  libSassy.Arrays,
  libSassy.Config,
  libSassy.Strings,
  libSassy.Streams,
  libSassy.Errors;

type
  TXMLElementType = (xeText, xeCData,  xeComment, xeAttribute, xeNode);

  TXMLError = class(TException);

{$REGION 'TXMLElement'}
  TXMLElement = class abstract(TInterface)
  private
    fName:        String;
    fParent:      TXMLElement;
    fElementType: TXMLElementType;

    function  GetContent: String;        virtual; abstract;
    procedure SetContent(Value: String); virtual; abstract;
  protected
    property Name: String read fName write fName;
  public
    constructor Create(const AParent: TXMLElement);

    procedure Clear; virtual; abstract;

    property Parent:      TXMLElement     read fParent;
    property ElementType: TXMLElementType read fElementType;

    property Content: String read GetContent write SetContent;
  end;
{$ENDREGION}

{$REGION 'TXMLTextElement'}
  TXMLTextElement = class(TXMLElement)
  private
    fContent: String;

    function  GetContent: String;        override;
    procedure SetContent(Value: String); override;
  public
    constructor Create(const AParent: TXMLElement);

    procedure Clear; override;

    property RawContent: String read fContent write fContent;
  end;
{$ENDREGION}

{$REGION 'TXMLAttributeElement'}
  TXMLAttributeElement = class(TXMLElement)
  private
    fAttributes: TValues;

    function  GetContent: String;        override;
    procedure SetContent(Value: String); override;
  public
    constructor Create(const AParent: TXMLElement);
    destructor  Destroy; override;

    procedure Clear; override;

    property Name;

    property Attributes: TValues read fAttributes;
  end;
{$ENDREGION}

{$REGION 'TXMLNodeElement'}
  TXMLNodeElement = class(TXMLAttributeElement)
  private
    fElements: TArray<TXMLElement>;

    function  GetTextContent: String;
    procedure SetTextContent(Value: String);

    function  GetContent: String; override;
    procedure SetContent(Value: String); override;
  public
    constructor Create(const AParent: TXMLElement);
    destructor  Destroy; override;

    procedure Clear; override;

    function CreateTextElement     (AContent: String = ''; AElementType: TXMLElementType = xeText; Index: Integer = -1): TXMLTextElement;
    function CreateAttributeElement(AName: String; Index: integer = -1): TXMLAttributeElement;
    function CreateNodeElement     (AName: String; Index: Integer = -1): TXMLNodeElement;

    function  GetNode   (Path: String; CanCreate: Boolean = False): TXMLNodeElement;
    function  NodeExists(Path: String): Boolean; inline;

    function  Read (Path: String; Default: String = ''): String;
    procedure Write(Path: String; Value:   String);

    property Elements: TArray<TXMLElement> read fElements;

    property TextContent: String read GetTextContent write SetTextContent;
  end;
{$ENDREGION}

{$REGION 'TXMLDocument'}
  TXMLDocument = class(TXMLNodeElement)
  public
    constructor Create;

    function LoadFromStream(Stream: TStream): Boolean;
    function SaveToStream  (Stream: TStream; const Unicode: Boolean = False): Boolean;
  end;
{$ENDREGION}

implementation

{$REGION 'TXMLElement'}
constructor TXMLElement.Create;
begin
  inherited Create;

  fName   := '';
  fParent := AParent;
end;
{$ENDREGION}

{$REGION 'TXMLTextElement'}
function TXMLTextElement.GetContent;
begin
  if fElementType = xeText then
    Result := fContent.UnMarkup(True)
  else
    Result := fContent;
end;

procedure TXMLTextElement.SetContent;
begin
  if fElementType = xeText then
    fContent := Value.Markup(True)
  else
    fContent := Value;
end;

constructor TXMLTextElement.Create;
begin
  inherited;

  fElementType := xeText;
end;

procedure TXMLTextElement.Clear;
begin
  fContent := '';
end;
{$ENDREGION}

{$REGION 'TXMLAttributeElement'}
function TXMLAttributeElement.GetContent;
begin
  // TODO: TXMLAttributeElement.GetContent
  Result := '';
end;

procedure TXMLAttributeElement.SetContent;
begin
  // TODO: TXMLAttributeElement.SetContent
end;

constructor TXMLAttributeElement.Create;
begin
  inherited;

  fElementType := xeAttribute;

  fAttributes := TValues.Create;
end;

destructor TXMLAttributeElement.Destroy;
begin
  fAttributes.Free;

  inherited;
end;

procedure TXMLAttributeElement.Clear;
begin
  fAttributes.Clear;
end;
{$ENDREGION}

{$REGION 'TXMLNodeElement'}
function TXMLNodeElement.GetTextContent;
var
  e: TXMLElement;
  s: String;
begin
  Result := '';

  for e in Elements do
    if e.ElementType in [xeText, xeCData] then
    begin
      s := e.Content;
      if s.Empty then continue;

      if not Result.Empty then Result := Result + #13#10;

      Result := Result + s;
    end;
end;

procedure TXMLNodeElement.SetTextContent;
var
  i: Integer;
  e: TXMLElement;
begin
  e := nil;

  for i := 0 to Elements.Count - 1 do
    if Elements[i].ElementType in [xeText, xeCData] then
    begin
      e := Elements[i];
      break;
    end;

  if e = nil then
  begin
    CreateTextElement(Value, xeCData, 0);
    exit;
  end;

  e.fElementType := xeCData;
  e.Content      := Value;

  for i := Elements.Count - 1 downto 0 do
    if (Elements[i] <> e) and (Elements[i].ElementType in [xeText, xeCData]) then
    begin
      Elements[i].Free;
      Elements.Delete(i);
    end;
end;

function TXMLNodeElement.GetContent;
  procedure WriteLine(Str: String; Indent: Integer; var Result: String);
  var
    i: Integer;
  begin
    if Str.Empty then exit;

    for i := 1 to Indent do
      Result := Result + '  ';

    Result := Result + Str + #13#10;
  end;

  function GetContentNode(Node: TXMLNodeElement; Indent: Integer): String;
  var
    e: TXMLElement;
    s: String;
  begin
    Result := '';

    with Node do
      for e in Elements do
        case e.ElementType of
          xeNode:
          begin
            s := '<' + e.Name;

            if TXMLNodeElement(e).Attributes.Values.Count > 0 then
              s := s + ' ' + TXMLNodeElement(e).Attributes.AsText;

            if TXMLNodeElement(e).Elements.Count > 0 then
            begin
              WriteLine(s + '>', Indent, Result);

              Result := Result + GetContentNode(TXMLNodeElement(e), Indent + 1);

              WriteLine('</' + e.Name + '>', Indent, Result);
            end

            else WriteLine(s + ' />', Indent, Result);
          end;

          xeAttribute:
            with TXMLAttributeElement(e) do
            begin
              s := '<?' + Name;

              if Attributes.Values.Count > 0 then
                s := s + ' ' + Attributes.AsText;

              WriteLine(s + ' ?>', Indent, Result);
            end;

          xeText:    WriteLine(              TXMLTextElement(e).Content,         Indent, Result);
          xeCData:   WriteLine('<![CDATA[' + TXMLTextElement(e).Content + ']]>', Indent, Result);
          xeComment: WriteLine('<!--'      + TXMLTextElement(e).Content + '-->', Indent, Result);
        end;
  end;
begin
  Result := GetContentNode(Self, 0);
end;

procedure TXMLNodeElement.SetContent;
var
  i:      Integer;
  Source: String;

  function Starts(Str: String): Boolean;
  begin
    Result := Source.Copy(i, Str.Length).Compare(Str, True) = 0;
    if Result then inc(i, Str.Length);
  end;

  function BuildNode(Root: TXMLNodeElement): Boolean;
  var
    j:    Integer;
    s, n: String;
    c, q: Char;
    f:    Boolean;
    Node: TXMLNodeElement;
  begin
    Result := False;

    repeat
      if Starts('<!--') then
      begin
        j := Source.Pos('-->', i);
        s := Source.Copy(i, j - i);
        i := j + 3;

        if s.Empty then continue;
        Root.CreateTextElement(s, xeComment);
      end

      else if Starts('<![cdata[') then
      begin
        j := Source.Pos(']]>', i);
        s := Source.Copy(i, j - i);
        i := j + 3;

        if s.Empty then continue;
        Root.CreateTextElement(s, xeCData);
      end

      else if Starts('</') then
      begin
        j := Source.Pos('>', i);
        s := Source.Copy(i, j - i);
        i := j + 1;

        if s.Empty then exit;
        if s.Compare(Root.Name, True) = 0 then break;

        exit;
      end

      else if Starts('<') then
      begin
        q := #0; s := '';

        repeat
          c := Source[i];
          s := s + c;

          if q <> #0 then
          begin
            if c = q then q := #0;
          end
          else
          begin
            if String.QuoteChars.Contains(c) then q := c;
          end;

          if (c = '>') and (q = #0) then break;
          inc(i);
        until i > Source.Length;

        s := s.Copy(1, s.Length - 1);
        inc(i);

        n := s.Split(' ');

        if n.Empty then exit;

        if n[1] = '?' then
        begin
          n := n.Copy(2);
          if n.Empty then exit;

          if (not s.Empty) and  (s[s.Length] = '?') then s := s.Copy(1, s.Length - 1);

          Root.CreateAttributeElement(n).Attributes.AddAsText(s);
        end
        else
        begin
          Node := Root.CreateNodeElement(n);

          f := (not S.Empty) and (s[s.Length] = '/');

          if f then s := s.Copy(1, s.Length - 1).Trim;
          Node.Attributes.AddAsText(s);

          if not f then
          begin
            Result := BuildNode(Node);
            if not Result then exit;
          end;
        end;
      end

      else
      begin
        j := Source.Pos('<', i);
        s := Source.Copy(i, j - i).Tidy;
        i := j;

        if s.Empty then continue;
        Root.CreateTextElement(s, xeText);
      end;
    until (i > Source.Length) or (i = 0);

    Result := True;
  end;
begin
  Clear;

  Source := Value.Tidy;
  if Source.Empty then exit;

  i := 1;

  BuildNode(Self);
end;

constructor TXMLNodeElement.Create;
begin
  inherited;

  fElementType := xeNode;

  fElements := TArray<TXMLElement>.Create;

  fElements.CompareProc := function(const A, B): Integer
  begin
    Result := TXMLElement(A).Name.Compare(TXMLElement(B).Name, True);
  end;

  fElements.DelProc := procedure(const A)
  begin
    TXMLElement(A).Free;
  end;
end;

destructor TXMLNodeElement.Destroy;
begin
  Clear;
  fElements.Free;

  inherited;
end;

procedure TXMLNodeElement.Clear;
begin
  inherited;

  fElements.Clear;
end;

function TXMLNodeElement.CreateTextElement;
begin
  if not (AElementType in [xeText, xeCData, xeComment]) then TXMLError.RaiseException('Invalid text element type');

  Result := TXMLTextElement.Create(Self);

  Result.fElementType := AElementType;
  Result.Content      := AContent;

  Elements.Add(Result, Index);
end;

function TXMLNodeElement.CreateAttributeElement;
begin
  Result := TXMLAttributeElement.Create(Self);

  Result.Name := AName.Lowercase;

  Elements.Add(Result, Index);
end;

function TXMLNodeElement.CreateNodeElement;
begin
  Result := TXMLNodeElement.Create(Self);

  Result.Name := AName.Lowercase;

  Elements.Add(Result, Index);
end;

function TXMLNodeElement.GetNode;
var
  f:       Boolean;
  i, c:    Integer;
  p, n, t: String;
  e:       TXMLElement;
begin
  Result := Self;

  if Path.Empty then exit;

  p := Path.Lowercase;

  repeat
    n := p.Split('/');
    if n.Empty then break;

    if n.Pos(':') > 0 then
    begin
      t := n.Split(':');
      i := n.AsInteger;
      n := t;
    end
    else
      i := 0;

    if n = '.'  then continue;
    if n = '..' then
    begin
      if Result.Parent <> nil then Result := TXMLNodeElement(Result.Parent);

      continue;
    end;

    c := -1; f := False;
    for e in Result.Elements do
      if (e is TXMLNodeElement) and (e.Name = n) then
      begin
        inc(c);

        if c = i then
        begin
          Result := TXMLNodeElement(e);
          f      := True;
          break;
        end;
      end;

    if not f then
      if CanCreate then
        Result := TXMLNodeElement(Result).CreateNodeElement(n)
      else
        exit(nil);
  until False;
end;

function TXMLNodeElement.NodeExists;
begin
  Result := GetNode(Path, False) <> nil;
end;

function TXMLNodeElement.Read;
var
  p, a: String;
  t:    Boolean;
  n:    TXMLNodeElement;
begin
  a := Path.Lowercase;
  p := a.Split('.');

  t := a.Empty and (not p.Empty) and (p[p.Length] = '=');

  if t then p := p.copy(1, p.Length - 1);

  n := GetNode(p, False);

  if n = nil then exit(Default);

  if t then Result := n.Content

  else if a.Empty then Result := n.TextContent

  else Result := n.Attributes.Read(a, Default);
end;

procedure TXMLNodeElement.Write;
var
  p, a: String;
  n:    TXMLNodeElement;
begin
  a := Path; p := a.Split('.');

  n := GetNode(p, True);

  if a.Empty then n.Content := Value else n.Attributes.Write(a, Value);
end;
{$ENDREGION}

{$REGION 'TXMLDocument'}
constructor TXMLDocument.Create;
begin
  inherited Create(nil);
end;

function TXMLDocument.LoadFromStream;
var
  S: String;
begin
  Result := S.Load(Stream);
  if not Result then exit;

  if S.Copy(1, 10).Compare('<!DOCTYPE ', False) = 0 then
    S := S.Copy(S.Pos('>', 10) + 1);

  Content := S;
end;

function TXMLDocument.SaveToStream;
var
  S: String;
begin
  S := '<!DOCTYPE xml>'#13#10 + Content;

  Result := S.Save(Stream, Unicode);
end;
{$ENDREGION}

end.