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

Previous  Top  Next

    
 

 

Автор: Delirium
Сайт: http://delphibase.endimus.com

Code:

{ **** 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.

 

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

Code:

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;

©Drkb::03113

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