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

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

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

{ **** UBPFD *********** by delphibase.endimus.com ****

>> .

Для задачи десериализации мне потребовался парсер.

Основное преимущество - никак не связан с операционной системой

(в отличие от TXMLDocument), ну и разумеется - простота :)

Зависимости: SysUtils, StrUtils

Автор: Delirium, <a href="mailto:VideoDVD@hotmail.com">VideoDVD@hotmail.com</a>, 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;

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

Отправить комментарий

Проверка
Антиспам проверка
Image CAPTCHA
...