Delphi World - Парсер подавляющего большинства нотаций XML
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Парсер подавляющего большинства нотаций XML

Автор: Delirium
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Парсер подавляющего большинства нотаций XML.

Для задачи десериализации мне потребовался парсер.
Основное преимущество - никак не связан с операционной системой
(в отличие от TXMLDocument), ну и разумеется - простота :)

Зависимости: SysUtils, StrUtils
Автор:       Delirium, VideoDVD@hotmail.com, ICQ:118395746, Москва
Copyright:   Delirium (Master BRAIN) 2003
Дата:        16 сентября 2003 г.
***************************************************** }

unit BNFXMLParser;

interface

uses SysUtils, StrUtils;

type
  PXMLNode = ^TXMLNode;

  TXMLValues = (TextNode, XMLNode);
  TXMLNode = record
    Name: string;
    Attributes: array of record
      Name: string;
      Value: string;
    end;
    SubNodes: array of record
      RecType: TXMLValues;
      case TXMLValues of
        TextNode: (Text: PString);
        XMLNode: (XML: PXMLNode);
    end;
    Parent: PXMLNode;
  end;

function BNFXMLTree(var Value: string): PXMLNode;

implementation

function fnTEG(var Node: PXMLNode; var Value: string): boolean; forward;
function fnVAL(var Node: PXMLNode; var Value: string): boolean; forward;
function fnATT(var Node: PXMLNode; var Value: string): boolean; forward;

function fnXML(var Node: PXMLNode; var Value: string): boolean;
var
  i: integer;
begin
  if (Pos('<', Value) > 0)
    and (Pos('>', Value) > Pos('<', Value))
    and (Pos('<', Value) <> Pos('</', Value)) then
  begin
    // Оганизую узел
    if Node = nil then
    begin
      New(Node);
      Node.Parent := nil;
    end
    else
    begin
      i := length(Node.SubNodes);
      Setlength(Node.SubNodes, i + 1);
      New(Node.SubNodes[i].XML);
      Node.SubNodes[i].RecType := XMLNode;
      Node.SubNodes[i].XML.Parent := Node;
      Node := Node.SubNodes[i].XML;
    end;
    Result := fnTEG(Node, Value);
  end // '<'
  else
    Result := True;
end;

function fnTEG(var Node: PXMLNode; var Value: string): boolean;
var
  i, i1, i2, i3: integer;
  S: string;
begin
  Result := False;
  i1 := Pos('<', Value);
  if i1 > 0 then
  begin
    i2 := PosEx('/>', Value, i1);
    i3 := PosEx('>', Value, i1);
    if (i2 > 0) and (i2 < i3) then
    begin // <abc/>
      // Value
      S := Copy(Value, i1 + 1, (i2 - i1) - 1);
      Delete(Value, i1, (i2 - i1) + 2);
      // TEXT, этот текст пренадлежит предку
      if Node.Parent <> nil then
      begin // Добавляюсь к предку
        i := length(Node.Parent.SubNodes);
        Setlength(Node.Parent.SubNodes, i + 1);
        New(Node.Parent.SubNodes[i].Text);
        Node.Parent.SubNodes[i].RecType := TextNode;
        Node.Parent.SubNodes[i].Text^ := Copy(Value, 1, Pos('<', Value) - 1);
      end;
      Delete(Value, 1, Pos('<', Value) - 1);
      //
      if fnVAL(Node, S) then
      begin // Вложенных тегов не бывает
        Node := Node.Parent;
        Result := fnXML(Node, Value);
      end;
    end
    else
    begin // <abc>...</abc>
      // Value
      S := Copy(Value, i1 + 1, (i3 - i1) - 1);
      Delete(Value, i1, (i3 - i1) + 1);
      // TEXT
      i := length(Node.SubNodes);
      Setlength(Node.SubNodes, i + 1);
      New(Node.SubNodes[i].Text);
      Node.SubNodes[i].RecType := TextNode;
      Node.SubNodes[i].Text^ := Copy(Value, 1, Pos('<', Value) - 1);
      Delete(Value, 1, Pos('<', Value) - 1);
      //
      if fnVAL(Node, S) then
      begin // Val
        // Проверяю закрытие тега, удаляю хвост и передаю управление предку
        if Pos('</' + AnsiLowerCase(Node.Name) + '>', AnsiLowerCase(Value)) = 1
          then
        begin
          Delete(Value, 1, Length('</' + Node.Name + '>'));
          // TEXT принадлежащий предку
          if Node.Parent <> nil then
          begin // Добавляюсь к предку
            i := length(Node.Parent.SubNodes);
            Setlength(Node.Parent.SubNodes, i + 1);
            New(Node.Parent.SubNodes[i].Text);
            Node.Parent.SubNodes[i].RecType := TextNode;
            Node.Parent.SubNodes[i].Text^ := Copy(Value, 1, Pos('<', Value) -
              1);
          end;
          Delete(Value, 1, Pos('<', Value) - 1);
          Node := Node.Parent;
          Result := fnXML(Node, Value);
        end
        else
        begin
          // Обрабатываю вложенные теги, на выходе мой узел
          if fnXML(Node, Value) then
          begin
            // закрываю его
            if Pos('</' + AnsiLowerCase(Node.Name) + '>', AnsiLowerCase(Value))
              = 1 then
            begin
              Delete(Value, 1, Length('</' + Node.Name + '>'));
              // TEXT принадлежащий предку
              if Node.Parent <> nil then
              begin // Добавляюсь к предку
                i := length(Node.Parent.SubNodes);
                Setlength(Node.Parent.SubNodes, i + 1);
                New(Node.Parent.SubNodes[i].Text);
                Node.Parent.SubNodes[i].RecType := TextNode;
                Node.Parent.SubNodes[i].Text^ := Copy(Value, 1, Pos('<', Value)
                  - 1);
              end;
              Delete(Value, 1, Pos('<', Value) - 1);
            end;
            // Остальной XML - предку
            if Node.Parent <> nil then
              Node := Node.Parent;
            Result := fnXML(Node, Value);
          end;
        end;
      end; // Val
    end; // <abc>...</abc>
  end; // i1
end;

function fnVAL(var Node: PXMLNode; var Value: string): boolean;
begin
  Value := AnsiReplaceStr(Value, '''', '"');
  if (Pos(' ', Value) > 0)
    and (Pos('="', Value) > Pos(' ', Value)) then
  begin
    Node.Name := Trim(Copy(Value, 1, Pos(' ', Value) - 1)); // Название тега Name
    Delete(Value, 1, Pos(' ', Value));
    Result := fnATT(Node, Value);
  end // ' ' и ('="'
  else
  begin
    // Название тега Name
    Value := Trim(Value);
    if Pos(' ', Value) > 0 then
      Node.Name := Copy(Value, 1, Pos(' ', Value) - 1)
    else
      Node.Name := Value;
    Value := '';
    Result := True;
  end;
end;

function fnATT(var Node: PXMLNode; var Value: string): boolean;
begin
  Result := True;
  Value := Trim(Value);
  if Pos('="', Value) > 0 then
  begin
    Result := False;
    SetLength(Node.Attributes, Length(Node.Attributes) + 1);
    // Название атрибута
    Node.Attributes[Length(Node.Attributes) - 1].Name := Trim(Copy(Value, 1,
      Pos('="', Value) - 1));
    Delete(Value, 1, Pos('="', Value) + 1);
    if Pos('"', Value) > 0 then
    begin
      // Значение атрибута
      Node.Attributes[Length(Node.Attributes) - 1].Value := Copy(Value, 1,
        Pos('"', Value) - 1);
      Delete(Value, 1, Pos('"', Value));
      if Length(Value) > 0 then
        Result := fnATT(Node, Value)
      else
        Result := True;
    end;
  end;
end;

function BNFXMLTree(var Value: string): PXMLNode;
begin
  Result := nil;
  fnXML(Result, Value);
end;

end.

Пример использования:

procedure TForm1.Button1Click(Sender: TObject);
var
  S: string;
  Node: PXMLNode;
  i: integer;
begin
  S := '<A> aaa1 ' + #13 +
    ' aaa2 aaa3 ' + #13 +
    ' <B>bbb ' + #13 +
    ' <C>ccc</C> ' + #13 +
    ' </B> ' + #13 +
    ' <D>ddd ' + #13 +
    ' <E eee="EEE"/> ' + #13 +
    ' </D> ' + #13 +
    '</A> ';
  Node := BNFXMLTree(S);
  for i := 0 to Length(Node.SubNodes) - 1 do
    case Node.SubNodes[i].RecType of
      TextNode: ShowMessage('Text = ' + Node.SubNodes[i].Text^);
      XMLNode: ShowMessage('XML Node name = ' + Node.SubNodes[i].XML.Name);
    end;
end;
Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования