Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

Парсер подавляющего большинства нотаций XML

01.01.2007

Автор: Delirium

Сайт: 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;

Взято из https://forum.sources.ru