XML解释器

(*
Here I will show one way to parse XML document
The main concept of XML is using containers for XML objects -
so we will use Tree concept while building our XML object from XML document.
XML text uses containers (<TAG ... >...</TAG>) or simple definitions (<TAG ... />)
in each TAG we can use parameters (<TAG key1="value1" key2="value2">... <SIMPLE key3="value3"> ...</TAG>)
Finally we will have an array of objects, describing XML tags. Every object of this
class will have an array of children if needed, and a hash to describe properties of it.
For example if we have a text
<UL name="xxx">
 <LI name="xxx1"/>
 <LI name="xxx2"/>
 <LI name="xxx3"/>
 <LI name="xxx4"/>
</UL>
we will have one root object (named "UL") in wich we will have 4 children
(named "LI" with different sets of properties - from "NAME"="xxx1" to "NAME"="xxx4")
This is not a trivial task - so we will make a unit to solve this...
I will try to comment some here...
if you have any comments for this unit - write to me: sunworx@mail.ru; yz@infoteh.ru
*)
unit YZXMLParser;

interface

uses
 SysUtils, ComCtrls;

type  
 THashElement = record
   Key, Value: string;
 end;

type  
 THashElementArr = array of THashElement;
 // here  we declare a THash class to use in our parser
 // The concept of THash is to retreive named values from an array
 // Hash is an array where index is a string (example V[Key]=value,
 // whehe Key and Value are of type string)
 // The main purpose of this class is to rerurn a value of a String-named key
 //(example: s:=hash['someValue'])
 // the description of a hash element we use
type  
 THash = class(TObject)
 private
   Arr: THashElementArr;
   function GetValue(Key: string): string;
   procedure SetValue(Key: string; const VValue: string);
   function GetKeys: StrArr;
   function GetValues: StrArr;
   function GetCount: Integer;
   function Getempty: Boolean;
 public
   property Value[Key: string]: string read GetValue write SetValue; default;
   property Values: StrArr read GetValues;
   property Keys: StrArr read GetKeys;
   property Count: Integer read GetCount;
   property Empty: Boolean read Getempty;
   procedure Clear;
   constructor Create;
   destructor Destroy; override;
 end;
 TYZHash = THash;

type
 // Here we declare some definitions for our parser to know what
 // identifier we would receive next in our text
 // these  values will be used in the result of WhatNext() function which will scan text for keys
 TYZXMLMarker = (xmlOpenTag, xmlCloseTagShort, xmlCloseTag, xmlCloseTagLong,
   xmlEOF, xmlIdentifier, xmlunknown);
  {
   Because we use recursive definition of our class(as TreeView, where we declare children of
   the same type in opur type  declaration) we must use forward declaration
  }
 // The definition of a TAG class
 TYZXMLTag  = class;
 TYZXMLTags = array of TYZXMLTag;
 TYZXMLTag = class(TObject)
 private
   FData: TYZHash;
   FParent: TYZXMLTag;
   FName: string;
   function GetValue(AName: string): string;
   procedure SetName(const Value: string);
   procedure SetValue(AName: string; const Value: string);
   function GetCount: Integer;
   function GetValueNames: strarr;
 public
   Children: TYZXMLTags; // these are our child nodes
   Text: string;
   property Name: string read FName write SetName; // name of a tag
   property Values[AName: string]: string read GetValue write SetValue; default; // values of properties of a tag (hash values)
   property ValueNames: strarr read GetValueNames; // array of strings returniong names of all props of this tag
   property Count: Integer read GetCount; // a count of children of a tag (if this tag is a container)
   function SkipSpaces(var AData: string; var APos: Integer; RememberBreaks: Boolean = False): Char;
   // internal. for skip spaces (also CR or LF or other non-text chars) while parsing text
   function ParseValue(var AData: string; var APos: Integer): Boolean;
   // parse value (calling when found a parameter of a tag)
   function ParseName(var AData: string; var APos: Integer): Boolean;
   // parse key of parameter in a tag
   // these two procs used to parse any text found while parsing XML
   function ParseString(var AData: string; var APos: Integer; RememberBreaks: Boolean = False): string;
   function ParseQuotedString(var AData: string; var APos: Integer; QIndef: Char = '"'): string;
   // returnes the type of next identifier in XML
   function WhatNext(var AData: string; var APos: Integer; var ANext: Integer; RememberBreaks: Boolean = False): TYZXMLMarker;
   // This is a main procedure of our class - AData is a string,
   // containing all XML data (you can use TMemo.Text, for example, as a parameter of AData)
   function ParseXML(var AData: string; var APos: Integer): Boolean;
   // This function returnes a text string, built based on data, stored in an object.
   function GenerateXML(var AData: string; ATab: string = ''): Boolean;
   // returnes char from string at specified pos (#0 if not in range)
   function CharAt(var S: string; APos: Integer): Char;
   function TagNameExists(AName: string): Boolean;
   // Adds a child to children array of a current tag
   function AddChild: TYZXMLTag;
   // Initializes current tag and deletes all existing children
   procedure Clear; virtual;
   constructor Create(AParent: TYZXMLTag); virtual;
   destructor Destroy; virtual;
 end;

type  
 TYZXMLParser = class(TYZXMLTag)
 private
   Header: TYZHash;
   procedure _BuildTreeView(ATreeView: TTreeView; ANode: TTreeNode; ATag: TYZXMLTag);
 public
   property HeaderValues: TYZHash read Header;
   procedure BuildTreeView(ATreeView: TTreeView);
   function Parse(AData: string): Boolean;
   function Generate(var AData: string): Boolean;
   constructor Create;
   destructor Destroy;
 end;

implementation

//==============================================================================
{ TYZXMLTag }
function TYZXMLTag.AddChild: TYZXMLTag;
begin
 setlength(children, Length(children) + 1);
 Result := TYZXMLTag.Create(Self);
 children[Length(children) - 1] := Result;
end;
//------------------------------------------------------------------------------
procedure TYZXMLTag.Clear;
var  
 i: Integer;
begin
 for i := 0 to Count - 1 do if children[i] <> nil then Children[i].Destroy;
 setlength(children, 0);
 FData.Clear;
 Text := '';
end;
//------------------------------------------------------------------------------
constructor TYZXMLTag.Create(AParent: TYZXMLTag);
begin
 inherited Create;
 FData   := TYZHash.Create;
 FParent := AParent;
 Clear;
end;
//------------------------------------------------------------------------------
destructor TYZXMLTag.Destroy;
begin
 Clear;
 FData.Destroy;
end;
//------------------------------------------------------------------------------
function TYZXMLTag.GetCount: Integer;
begin
 Result := Length(children);
end;
//------------------------------------------------------------------------------
function TYZXMLTag.GetValue(AName: string): string;
begin
 Result := FData[AName];
end;
//------------------------------------------------------------------------------
function TYZXMLTag.ParseName(var AData: string; var APos: Integer): Boolean;
begin
 Result := False;
 FName  := ParseString(AData, APos);
 if fname = '' then Exit;
 Result := True;
end;
//------------------------------------------------------------------------------
function TYZXMLTag.ParseQuotedString(var AData: string; var APos: Integer;
 QIndef: Char = '"'): string;
var  
 i: Integer;
 skipnext: Boolean;
 z: Char;
begin
 Result := '';
 if CharAt(AData, APos) <> QIndef then Exit;
 i        := apos;
 skipnext := True;
 repeat
   if not skipnext then
   begin
     if charat(AData, I) = '\' then SkipNext := True  
     else
     begin
       z := charat(AData, I);
       if (Z = QIndef) or (z = #0) then
       begin
         Result := Copy(AData, aPos + 1, I - APos - 1);
         //          result:=exch(result,'\','');
         APos := I + 1;
         Exit;
       end;
     end;
   end  
   else  
     skipnext := False;
   Inc(i);
 until False;
end;
//------------------------------------------------------------------------------
function TYZXMLTag.ParseString(var AData: string; var APos: Integer;
 RememberBreaks: Boolean = False): string;
const  
 extsym: string = '=<>;?*/';
var  
 nxt: Char;
 x1, x2, i: Integer;
begin
 Result := '';
 nxt    := SkipSpaces(AData, APos, RememberBreaks);
 if nxt = #0 then Exit;
 if (nxt = '"') or (nxt = '''') then  
 begin  
   Result := ParseQuotedString(AData, APos);  
   Exit;  
 end;
 x1  := APos;
 i   := x1;
 nxt := CharAt(AData, i);
 while ((Ord(nxt) <= 32) or (Pos(nxt, extsym) > 0)) and (nxt <> #0) do  
 begin  
   Inc(i);  
   nxt := CharAt(AData, i);  
 end;
 APos := i;
 X1 := APos;
 while (Ord(nxt) > 32) and (Pos(nxt, extsym) <= 0) do  
 begin  
   Inc(i);  
   nxt := CharAt(AData, i);  
 end;
 x2 := i - x1;
 Result := Copy(AData, x1, x2);
 APos := i;
end;
//------------------------------------------------------------------------------
function TYZXMLTag.ParseValue(var AData: string; var APos: Integer): Boolean;
var  
 n, v: string;
 i, x: Integer;
begin
 Result := False;
 n := parseString(AData, APos);
 if n = '' then Exit;
 if skipspaces(AData, APos) <> '=' then Exit;
 Inc(apos);
 V := parseString(AData, APos);
 fdata[n] := dequote(v);
 Result := True;
end;
//------------------------------------------------------------------------------
function TYZXMLTag.ParseXML(var AData: string; var APos: Integer): Boolean;
var  
 N: TYZXMLMarker;
 nxt: Integer;
 isLong: Boolean;
 inTag: Boolean;
begin
 isLong := False;
 Result := False;
 Clear;
 if WhatNext(AData, APos, nxt) <> xmlOpenTag then Exit;
 APos := nxt;
 if WhatNext(AData, APos, nxt) <> xmlIdentifier then Exit;
 Result := ParseName(AData, APos);
 if not Result then Exit;
 intag  := True;
 Result := False;
 while True do
 begin
   N := WhatNext(AData, APos, nxt, (not intag and islong and (Count > 0)));
   case N of
     xmlEOF: Exit;
     xmlCloseTagLong:  
       begin  
         Result := True;  
         if islong then APos := nxt;  
         if (Text <> '') and (Count > 0) then  
         begin  
           Text := exch(Text, #13#10#13#10, #13#10);  
         end;
         Exit;  
       end;
     xmlCloseTagShort:  
       begin  
         Result := (not IsLong) and intag;  
         if Result then APos := nxt;  
         Exit;  
       end;
     xmlOpenTag:  
       begin  
         if islong then Result := AddChild.ParseXML(AData, APos)  
         else  
         begin  
           Result := False;  
           Exit;  
         end;  
         if not Result then Exit;  
       end;
     xmlCloseTag:  
       begin  
         IsLong := True;  
         APos   := nxt;  
         intag  := False;  
       end;
     xmlIdentifier:  
       begin  
         if intag then parsevalue(AData, APos)  
         else  
           Text := Text + ParseString(AData, APos, True)  
       end;
     xmlUnknown:  
       begin  
         Result := True;  
         Exit;  
       end;
   end;
 end;
end;
//------------------------------------------------------------------------------
procedure TYZXMLTag.SetName(const Value: string);
begin
 FName := Value;
end;
//------------------------------------------------------------------------------
procedure TYZXMLTag.SetValue(AName: string; const Value: string);
begin
 FData[AName] := Value;
end;
//------------------------------------------------------------------------------
function TYZXMLTag.SkipSpaces(var AData: string; var APos: Integer;
 RememberBreaks: Boolean = False): Char;
var  
 L: Integer;
 P: Char;
begin
 L := Length(AData);
 while APos <= L do
 begin
   P := AData[APos];
   if Ord(p) > 32 then  
   begin  
     Result := p;  
     Exit;  
   end  
   else if rememberbreaks then
   begin
     if Pos(p, #13#9' ') > 0 then
       Text := Text + ' ';
   end;
   Inc(APos);
 end;
 Result := #0;
end;
//------------------------------------------------------------------------------
function TYZXMLTag.CharAt(var S: string; APos: Integer): Char;
begin
 Result := #0;
 if (Length(s) < APos) or (apos < 1) then Exit;
 Result := s[APos];
end;
//------------------------------------------------------------------------------
function TYZXMLTag.WhatNext(var AData: string; var APos: Integer;
 var ANext: Integer; RememberBreaks: Boolean = False): TYZXMLMarker;
var  
 s: string;
 C: Char;
 P: Integer;
begin
 Result := xmlEOF;
 P := APos;
 C := SkipSpaces(AData, APos);
 P := APos;
 ANext  := P;
 if C = #0 then Exit;
 if C = '<' then if CharAt(AData, P + 1) = '/' then
   begin
     Inc(P, 2);
     s := parsestring(AData, P);
     if (uppercase(s) = uppercase(FName)) and (SkipSpaces(AData, P) = '>') then
     begin  
       ANext := P + 1;
       Result := xmlCloseTagLong;  
       Exit;  
     end  
     else
     begin
       if TagNameExists(s) then
       begin
         Result := xmlCloseTagLong;
         ANext := APos;
         Exit;
       end;
       ANext  := P + 1;
       Result := xmlCloseTagLong;
       Exit;
     end;
   end;
 if C = '<' then  
 begin  
   ANext := P + 1;
   Result := xmlOpenTag;  
   Exit;  
 end;
 if C = '>' then  
 begin  
   ANext := P + 1;
   Result := xmlCloseTag;  
   Exit;  
 end;
 if C = '/' then if CharAt(AData, P + 1) = '>' then  
   begin  
     ANext := P + 2;
     Result := xmlCloseTagShort;  
     Exit;
   end;
 ANext := P;
 parsestring(AData, ANext);
 Result := xmlIdentifier;
end;
//------------------------------------------------------------------------------
function TYZXMLTag.GetValueNames: strarr;
begin
 Result := FData.Keys;
end;
//------------------------------------------------------------------------------
function TYZXMLTag.GenerateXML(var AData: string; ATab: string = ''): Boolean;
var  
 valDelimiter: string;
 spc: string;
 i: Integer;
 a: strarr;
begin
 spc := ATab + #9;
 if FData.Count < 5 then valDelimiter := ' '  
 else  
   valDelimiter := #13#10 + spc;
 AData := AData + #13#10 + ATab + '<' + FName;
 a     := FData.keys;
 for i := 0 to Length(a) - 1 do
 begin
   AData := AData + valDelimiter + a[i] + ' = "' + EnQuote(values[a[i]]) + '"';
 end;
 if (Count > 0) or (Text <> '') then
 begin
   AData := AData + '>' + Text;
   for i := 0 to Count - 1 do
   begin
     Children[i].GenerateXML(AData, ATab + #9);
   end;
   AData := AData + #13#10 + ATab + '</' + FName + '>';
 end  
 else  
   AData := AData + '/>';
 Result := True;
end;
//------------------------------------------------------------------------------
function TYZXMLTag.TagNameExists(AName: string): Boolean;
begin
 Result := AnsiUpperCase(AName) = AnsiUpperCase(Self.FName);
 if Self.FParent = nil then Exit;
 if not Result then Result := fparent.TagNameExists(AName);
end;
//==============================================================================
{ TYZXMLParser }
constructor TYZXMLParser.Create;
begin
 Header := TYZHash.Create;
 inherited Create(nil);
end;
//------------------------------------------------------------------------------
destructor TYZXMLParser.Destroy;
begin
 inherited;
 Header.Destroy;
end;
//------------------------------------------------------------------------------
procedure TYZXMLParser.BuildTreeView(ATreeView: TTreeView);
var  
 i: Integer;
begin
 //  clear;
 ATreeView.Items.Clear;
 for i := 0 to Count - 1 do _BuildTreeView(ATreeView, nil, children[i]);
end;
//------------------------------------------------------------------------------
procedure TYZXMLParser._BuildTreeView(ATreeView: TTreeView; ANode: TTreeNode;
 ATag: TYZXMLTag);
var  
 i: Integer;
 N: TTreeNode;
begin
 N := ATreeView.Items.AddChildObject(ANode, ATag.Name + ' ' + FData['ID'], Pointer(ATag));
 for i := 0 to ATag.Count - 1 do
 begin
   if ATag.children[i] <> nil then _BuildTreeView(ATreeView, N, ATag.children[i])  
   else  
     ATreeView.Items.AddChild(N, 'nil');
 end;
 N.Expanded := True;
end;
//------------------------------------------------------------------------------
function TYZXMLParser.Parse(AData: string): Boolean;
var  
 x1, x2, X, i: Integer;
 s: string;
 tmp: TYZXMLTag;
 a: strarr;
 N: TYZXMLMarker;
begin
 X := 1;
 Self.SkipSpaces(AData, X);
 x2 := -1;
 Result := False;
 Clear;
 Header.Clear;
 x1 := Pos('<?', AData);
 if x1 >= X then
 begin
   x2 := Pos('?>', AData);
   if x2 < X then Exit;
   s := uppercase(Copy(AData, x1 + 2, 4));
   if Pos('XML ', s) <> 1 then Exit;
   s   := '<xml ' + Copy(AData, x1 + 6, x2 - x1 - 6) + '/>';
   tmp := TYZXMLTag.Create(nil);
   tmp.ParseXML(s, x);
   a := tmp.ValueNames;
   for i := 0 to Length(a) - 1 do
     Header[a[i]] := tmp.Values[a[i]];
   tmp.Destroy;
   x := x2 + 2;
 end;
 Result := True;
 repeat
   N := whatnext(AData, X, x1);
   case N of
     xmlOpenTag: Result := Result and AddChild.ParseXML(AData, X);
     xmlIdentifier:  
       begin  
         if Text <> '' then Text := Text + ' ';  
         Text := Text + parsestring(AData, X, True);  
       end;
     else  
       Parsestring(AData, X);
   end;
 until skipspaces(adata, x) = #0;
 //  if not result then ShowMessage('Error Parsing: '+inttostr(X));
end;

function TYZXMLParser.Generate(var AData: string): Boolean;
var  
 i: Integer;
 a: strarr;
begin
 Header['Date'] := DateTimeToStr(now);
 a := header.Keys;
 AData := '<?xml';
 for i := 0 to Length(a) - 1 do
   AData := AData + ' ' + a[i] + '="' + Header[a[i]] + '"';
 AData  := AData + '?>'#13#10 + Text;
 Result := True;
 for i := 0 to Length(children) - 1 do
 begin
   Result := Result and children[i].generatexml(AData);
 end;
end;
//==============================================================================
// procedures of THash class
//==============================================================================
{THASH CLASS}
procedure THash.Clear;
begin
 SetLength(Arr, 0);
end;
constructor THash.Create;
begin
 inherited;
 Clear;
end;
//------------------------------------------------------------------------------
destructor THash.Destroy;
begin
 Clear;
 inherited;
end;
//------------------------------------------------------------------------------
function THash.GetCount: Integer;
begin
 Result := Length(Arr);
end;
//------------------------------------------------------------------------------
function THash.Getempty: Boolean;
begin
 Result := Length(Arr) = 0;
end;
function THash.GetKeys: StrArr;
var  
 i: Integer;
begin
 SetLength(Result, Length(arr));
 for i := 0 to Length(Result) - 1 do
   Result[i] := arr[i].Key;
end;
//------------------------------------------------------------------------------
function THash.GetValue(Key: string): string;
var  
 i: Integer;
 r: Boolean;
begin
 Result := '';
 i      := 0;  
 r      := False;
 while (i < Length(Arr)) and (not r) do
 begin
   if AnsiUpperCase(arr[i].key) = AnsiUpperCase(Key) then  
   begin  
     Result := Arr[i].Value;  
     r := True;
   end;
   i := i + 1;
 end;
end;
//------------------------------------------------------------------------------
function THash.GetValues: StrArr;
var  
 i: Integer;
begin
 SetLength(Result, Length(arr));
 for i := 0 to Length(Result) - 1 do
   Result[i] := arr[i].Value;
end;
//------------------------------------------------------------------------------
procedure THash.SetValue(Key: string; const VValue: string);
var  
 i, j: Integer;
 r: Boolean;
 E: THashElementArr;
begin
 if VValue <> '' then
 begin
   i := 0;  
   r := False;
   while (i < Length(Arr)) and not r do
   begin
     if AnsiUpperCase(arr[i].key) = AnsiUpperCase(Key) then  
     begin  
       Arr[i].Value := VValue;  
       r := True;
     end;
     i := i + 1;
   end;
   if not r then  
   begin  
     SetLength(Arr, Length(arr) + 1);
     arr[Length(arr) - 1].Key   := Key;
     arr[Length(arr) - 1].Value := Vvalue;  
   end;
 end;
 SetLength(E, Length(Arr));
 for i := 0 to Length(arr) - 1 do E[i] := Arr[i];
 SetLength(arr, 0);
 for i := 0 to Length(E) - 1 do if (E[i].Key <> '') and (E[i].Value <> '') then
   begin
     j := Length(arr);
     setlength(arr, j + 1);
     arr[j] := E[i];
   end;
end;

end.