////////////////////////////////////////////////// // DB Access Components // Copyright © 1998-2007 Core Lab. All right reserved. // CRXml ////////////////////////////////////////////////// unit CRXml; interface {$I Dac.inc} uses Classes, SysUtils, Contnrs, CLRClasses; type TChars = array of char; TextReader = class end; StreamReader = class(TextReader) private FReader: TStream; FCapacity: Integer; FReleaseReader: Boolean; function Eof: Boolean; public constructor Create(const path: string; detectEncodingFromByteOrderMarks: Boolean); overload; constructor Create(input: TStream); overload; destructor Destroy; override; procedure Close; function Read(buffer: TChars; Index, Count: Integer):Integer; function ReadLine:string; function ReadToEnd:string; property BaseStream: TStream read FReader; end; StringReader = class(TextReader) private FText: string; public constructor Create(Text: string); end; StreamWriter = class private FWriter: TStream; FReleaseWriter: Boolean; FEncodingClass: EncodingClass; public constructor Create(const path: string; Append: Boolean); overload; constructor Create(output: TStream; Encoding: EncodingClass); overload; destructor Destroy; override; procedure Close; procedure Flush; procedure Write(value: string); procedure WriteLine(const value: string); end; XmlException = class(Exception); XmlNodeType = (ntNone, ntElement, ntAttribute, ntEndElement, ntComment, ntDeclaration, ntDocumentType, ntText); XmlReadState = (Initial, Interactive, Error, EndOfFile, Closed); XmlTextReader = class private FText: string; FTextlc: string; FPrefix: string; FValue: string; FName: string; FNodeType: XmlNodeType; FAttrNames: TStringList; FAttrPrefix: TStringList; FAttrValues: TStringList; FOffset: Integer; FTextLen: Integer; FState: XmlReadState; FCurrElementName: string; FReader: StreamReader; FEof: Boolean; function GetHasAttributes: Boolean; function GetDepth: integer; function GetAttributeCount: integer; procedure GetXMLNodeAttributes(const Node: string; AttrNames: TStrings; AttrValues: TStrings); procedure ReadFromStream; procedure InitInstance; function GetEof:Boolean; protected function ScanLine(Lexem: array of string; Offset: Integer = -1):Boolean; public constructor Create(Reader: TextReader); destructor Destroy; override; procedure MoveToAttribute(i: integer); overload; function MoveToAttribute(name: string):Boolean; overload; function Read: boolean; function MoveToElement: boolean; function Items(const Index: Integer): string; overload; function Items(const AttrName: string): string; overload; property Name: string read FName; property Prefix: string read FPrefix; property Value: string read FValue; property NodeType: XmlNodeType read FNodeType; property AttributeCount: integer read GetAttributeCount; property Depth: integer read GetDepth; property ReadState: XmlReadState read FState; property Eof: Boolean read FEof; property HasAttributes: Boolean read GetHasAttributes; end; XmlFormatting = (fmtNone, fmtIndented); XmlWriteState = (wsAttribute, wsClosed, wsContent, wsElement, wsStart); XmlTextWriter = class private FText: string; FFormatting: XmlFormatting; FIndentation: Integer; FIndentChar: Char; FQuoteChar: Char; FWriteState: XmlWriteState; FDepth: Integer; FPrefix: TStringList; FPosStack: TStack; FTagStack: TStringList; FWriter: StreamWriter; function IndentStr: string; function PopTagName: string; procedure PushTagName(const TagName: string); procedure InternalCloseStartTag; protected procedure InternalWriteStartElement(const Prefix, LocalName, ns: string); procedure InternalWriteElementString(const LocalName, ns, Value: string); procedure InternalWriteAttributeString(const Prefix, LocalName, ns, Value: string); procedure InternalWriteEndElement; procedure FlushData; public constructor Create(w: StreamWriter); destructor Destroy; override; procedure WriteStartElement(const LocalName: string); overload; procedure WriteStartElement(const Prefix, LocalName, ns: string); overload; procedure WriteStartElement(const LocalName, ns: string); overload; procedure WriteEndElement; procedure WriteFullEndElement; procedure WriteString(const Text: string); procedure WriteElementString(const LocalName, ns, value: string); overload; procedure WriteElementString(const LocalName, Value: string); overload; procedure WriteAttributeString(const LocalName, Value: string); overload; procedure WriteAttributeString(const Prefix, LocalName, ns, Value: string); overload; procedure Close; property Formatting: XmlFormatting read FFormatting write FFormatting; property Indentation: Integer read FIndentation write FIndentation; property IndentChar: Char read FIndentChar write FIndentChar; property QuoteChar: Char read FQuoteChar write FQuoteChar; property WriteState: XmlWriteState read FWriteState; end; implementation uses {$IFDEF VER7P} StrUtils, {$ENDIF} MemUtils, CRParser; const LineSeparator = #13#10; SInvalidXML = 'Invalid XML'; SClassNotSupported = 'Class %s is not supported'; procedure DeleteInvisibleSymbol(var s: string); forward; function XMLDecode(const AStr: String): String; forward; function CompareLexem(const s, Substr: string; Index: Integer):Boolean; forward; type TXmlParser = class(TParser) public constructor Create(const Text: string); override; end; var XmlSymbolLexems, XmlKeywordLexems: TStringList; { XmlTextReader } constructor XmlTextReader.Create(Reader: TextReader); begin inherited Create; if Reader.InheritsFrom(StreamReader) then begin FTextLen := -1; FReader := StreamReader(Reader); ReadFromStream; end else if Reader.InheritsFrom(StringReader) then begin FReader := nil; FText := StringReader(Reader).FText; FTextLen := Length(FText); FTextlc := LowerCase(FText); end else raise Exception.CreateFmt(SClassNotSupported, [Reader.ClassName]); InitInstance; end; destructor XmlTextReader.Destroy; begin FAttrNames.Free; FAttrPrefix.Free; FAttrValues.Free; inherited; end; procedure XmlTextReader.ReadFromStream; begin if Assigned(FReader) then begin if (FOffset >= FTextLen) then begin if not FReader.Eof then begin FText := ''; repeat FText := FText + ' ' + TrimRight(FReader.ReadLine); until (Pos('>', FText) <> 0) or FReader.Eof; FTextlc := LowerCase(FText); FTextLen := Length(FText); FOffset := 1; end else FEof := True; end; end; end; function XmlTextReader.MoveToElement: boolean; begin Result := False; end; function XmlTextReader.ScanLine(Lexem: array of string; Offset: Integer = -1):Boolean; var i: Integer; Str: string; begin ReadFromStream; Result := False; // Make compiler happy; if Offset <> -1 then FOffset := Offset; while (FOffset <= FTextLen) do begin Result := False; for i := Low(Lexem) to High(Lexem) do begin Str := Copy(FTextlc, FOffset, Length(Lexem[i])); if Str = Lexem[i] then begin Result := True; inc(FOffset, Length(Lexem[i])); break; end; end; if Result then break; inc(FOffset); end; if (not Result) and (not GetEof) then Result := ScanLine(Lexem); end; function XmlTextReader.Read: boolean; var Node: string; NextLexem: Integer; OldOffset: Integer; EndTagName: string; ChildTag: Integer; k: Integer; IsTextFound: Boolean; begin Result := False; ReadFromStream; if (FState in [Initial, Interactive]) then begin IsTextFound := False; if NodeType = ntElement then begin k := FOffset; while (FTextlc[k] <> '<') and (k <= Length(FTextlc)) do begin if FTextlc[k] in ['a'..'z', '0'..'9', '.', ':'] then begin IsTextFound := True; break; end; inc(k); end; if IsTextFound then begin FNodeType := ntText; inc(FOffset); end; end; if not IsTextFound then begin if not ScanLine(['<']) then begin if Eof then exit; FState := Error; XmlException.Create('Root element missing'); end; if FTextlc[FOffset] = '?' then FNodeType := ntDeclaration else if CompareLexem(FTextlc, '!--', FOffset) then FNodeType := ntComment else if CompareLexem(FTextlc, '!DOCTYPE', FOffset) then FNodeType := ntDocumentType else if FTextlc[FOffset] = '/' then begin FNodeType := ntEndElement; end else if (FTextlc[FOffset-1] = '<') then FNodeType := ntElement else Assert(False); end; FState := Interactive; end; FName := ''; FValue := ''; FPrefix := ''; case FNodeType of ntDeclaration: begin inc(FOffset); NextLexem := PosEx(' ', FTextlc, FOffset); if NextLexem <> -1 then begin FName := Trim(Copy(FText, FOffset, NextLexem-FOffset)); inc(FOffset, NextLexem-FOffset); end; if ScanLine(['?>']) then FValue := Trim(Copy(FText, NextLexem, FOffset-NextLexem-2)) else begin FState := Error; raise XmlException.Create('Invalid declaration tag'); end; Result := True; end; ntComment: begin inc(FOffset, 3); NextLexem := FOffset; if ScanLine(['-->']) then FValue := Trim(Copy(FText, NextLexem, FOffset - NextLexem - 3)) else begin FState := Error; raise XmlException.Create('Invalid comment tag'); end; Result := True; end; ntDocumentType: begin inc(FOffset, 8); NextLexem := FOffset; if ScanLine(['[<']) then begin FName := Trim(Copy(FText, NextLexem, FOffset - NextLexem - 2)); NextLexem := PosEx('>]', FTextlc, FOffset); FValue := Trim(Copy(FText, FOffset, NextLexem - FOffset)); inc(FOffset, NextLexem - FOffset) end else begin FState := Error; raise XmlException.Create('Invalid Document type tag'); end; Result := True; end; ntEndElement: begin inc(FOffset); NextLexem := PosEx('>', FTextlc, FOffset); FName := Trim(Copy(FText, FOffset, NextLexem - FOffset)); FOffset := NextLexem; Result := True; end; ntElement: begin if FTextlc[FOffset-1] = '<' then begin NextLexem := PosEx('>', FTextlc, FOffset); Node := Copy(FText, FOffset, NextLexem - FOffset+1); OldOffset := FOffset; ScanLine([' ','>']); FName := Trim(Copy(FText, OldOffset, FOffset - OldOffset - 1)); Delete(Node, 1, Length(FName)); GetXMLNodeAttributes(Node, FAttrNames, FAttrValues); FCurrElementName := FName; if FName[Length(FName)] = '/'then Delete(FName, Length(FName), 1); FOffset := NextLexem; Result := True; end; end; ntText: begin EndTagName := LowerCase(FCurrElementName); DeleteInvisibleSymbol(EndTagName); EndTagname := ''; if FCurrElementName[Length(FCurrElementName)] = '/' then NextLexem := FOffset + Length(FCurrElementName) else NextLexem := PosEx(EndTagName, FTextlc, FOffset); FValue := Trim(Copy(FText,FOffset, NextLexem - FOffset)); ChildTag := PosEx('<', FValue); if (ChildTag <> 0) and (not CompareLexem(FValue, '' break; lcIdent: begin WithColon := False; AttrName := Lexem; AttrPrefix := ''; Code := Parser.GetNext(Lexem); if Code = lcIdent then begin AttrName := Lexem; Code := Parser.GetNext(Lexem); end; if Code in [16, 19] then begin if Code = 16 then begin // ':' Code := Parser.GetNext(Lexem); if Code <> lcIdent then raise XmlException.Create(SInvalidXML); AttrPrefix := AttrName; AttrName := AttrPrefix + ':' + Lexem; Code := Parser.GetNext(Lexem); WithColon := True; end; if Code = 19 then begin // '=' Code := Parser.GetNext(Lexem); if (Code <> lcIdent) and (Code <> lcString) then raise XmlException.Create(SInvalidXML); AttrValue := XMLDecode({UTF8Decode}(Lexem)); if WithColon and (LowerCase(AttrName) = 'name') then AttrName := ':' + AttrName; AttrNames.Add(AttrName); AttrValues.Add(AttrValue); FAttrPrefix.Add(AttrPrefix); end; end; end; end; end; finally Parser.Free; end; Assert(AttrNames.Count = AttrValues.Count); end; function XMLDecode(const AStr: String): String; var sb: StringBuilder; begin sb := StringBuilder.Create(AStr, Length(AStr)); try sb.Replace(''', ''''); sb.Replace('"', '"'); sb.Replace('<', '<'); sb.Replace('>', '>'); sb.Replace('&', '&'); Result := sb.ToString; finally sb.Free; end; end; function XmlTextReader.Items(const Index: Integer): string; begin Result := FAttrValues[Index]; end; function XmlTextReader.Items(const AttrName: string): string; begin Result := Items(FAttrNames.IndexOf(AttrName)); end; function XmlTextReader.GetAttributeCount: integer; begin Result := FAttrNames.Count; end; procedure XmlTextReader.MoveToAttribute(i: integer); begin try FName := FAttrNames[i]; FValue := FAttrValues[i]; FPrefix := FAttrPrefix[i]; except raise XmlException.Create(Format('Attribute not found (%d)', [i])); end; end; function XmlTextReader.MoveToAttribute(name: string):Boolean; begin try MoveToAttribute(FAttrNames.IndexOf(name)); Result := True; except Result := False; end; end; function XmlTextReader.GetDepth: integer; begin Result := 0; end; function XmlTextReader.GetHasAttributes: Boolean; begin Result := FAttrNames.Count > 0; end; procedure DeleteInvisibleSymbol(var s: string); var i: Integer; begin for i := Length(s) downto 1 do if not ((s[i] in ['a'..'z']) or (s[i] <> '.') or (s[i] <> ':')) then Delete(s, i, 1); end; function CompareLexem(const s, Substr: string; Index: Integer):Boolean; var tmp: string; Len: Integer; begin Len := Length(Substr); tmp := Copy(s, Index, Len); Result := CompareText(tmp, Substr) = 0; end; procedure XmlTextReader.InitInstance; begin if FTextLen > 0 then FEof := False else FEof := True; FState := Initial; FNodeType := ntNone; FOffset := 1; FAttrNames := TStringList.Create; FAttrPrefix := TStringList.Create; FAttrValues := TStringList.Create; FCurrElementName := ''; end; function XmlTextReader.GetEof: Boolean; begin if Assigned(FReader) then Result := FReader.Eof else begin Result := FOffset >= FTextLen; FEof := Result; end; end; { XmlTextWriter } constructor XmlTextWriter.Create(w: StreamWriter); begin FFormatting := fmtNone; FIndentation := 2; FIndentChar := ' '; FQuoteChar := '"'; FWriteState := wsStart; FDepth := 0; FPrefix := TStringList.Create; FPosStack := TStack.Create; FTagStack := TStringList.Create; FWriter := w; end; destructor XmlTextWriter.Destroy; begin FPrefix.Free; FPosStack.Free; FTagStack.Free; inherited; end; procedure XmlTextWriter.InternalWriteStartElement(const Prefix, LocalName, ns: string); var EndTagPos: Integer; begin InternalCloseStartTag; if FWriteState = wsContent then FlushData; if FDepth > 0 then FText := FText + LineSeparator; if Prefix <> '' then FText := FText + IndentStr + '<' + Prefix + ':' + LocalName else FText := FText + IndentStr + '<' + LocalName; if ns <> '' then if Prefix <> '' then FText := FText + ' ' + 'xmlns:' + Prefix + '=' + FQuoteChar + ns + FQuoteChar else FText := FText + ' ' + 'xmlns=' + FQuoteChar + ns + FQuoteChar; EndTagPos := Length(FText); inc(FDepth); FPosStack.Push(Pointer(EndTagPos)); if Prefix <> '' then PushTagName(Prefix + ':' + LocalName) else PushTagName(LocalName); FWriteState := wsElement; end; procedure XmlTextWriter.InternalWriteElementString(const LocalName, ns, Value: string); begin InternalCloseStartTag; if FWriteState = wsElement then inc(FDepth); FText := FText + LineSeparator; FText := FText + IndentStr + '<' + LocalName; if ns <> '' then FText := FText + ' xmlns=' + FQuoteChar + ns + FQuoteChar + '>' else FText := FText + '>'; if Value <> '' then FText := FText + Value; FText := FText + ''; if FWriteState = wsElement then dec(FDepth); FlushData; FWriteState := wsContent; end; procedure XmlTextWriter.InternalWriteAttributeString(const Prefix, LocalName, ns, Value: string); var AttrPos: Integer; AttrStr: string; begin if FWriteState in [wsElement, wsAttribute] then AttrPos := Integer(FPosStack.Pop) + 1 else raise XmlException.Create('Token WriteAttributeString in state Content would result in an invalid XML document.'); if Prefix <> '' then AttrStr := ' ' + Prefix + ':' else AttrStr := ' '; AttrStr := AttrStr + LocalName + '=' + FQuoteChar + Value + FQuoteChar;// + ' '; Insert(AttrStr, FText, AttrPos); AttrPos := AttrPos + Length(AttrStr); if ns <> '' then begin AttrStr := 'xmlns:' + Prefix + '=' + FQuoteChar + ns + FQuoteChar;// + ' '; Insert(AttrStr, FText, AttrPos); AttrPos := AttrPos + Length(AttrStr); end; FPosStack.Push(Pointer(AttrPos-1)); FWriteState := wsAttribute; end; procedure XmlTextWriter.FlushData; begin FWriter.Write(FText); FText := ''; end; procedure XmlTextWriter.Close; begin FlushData; end; procedure XmlTextWriter.WriteStartElement(const LocalName: string); begin InternalWriteStartElement('', LocalName, ''); end; procedure XmlTextWriter.WriteStartElement(const Prefix, LocalName, ns: string); begin if (Prefix <> '') and (ns = '') then raise XmlException.Create('Cannot use a prefix with an empty namespace.'); InternalWriteStartElement(Prefix, LocalName, ns); end; procedure XmlTextWriter.WriteStartElement(const LocalName, ns: string); begin InternalWriteStartElement('', LocalName, ns); end; procedure XmlTextWriter.WriteEndElement; begin dec(FDepth); if (FWriteState = wsAttribute) then begin FText := FText + ' />'; PopTagName; FWriteState := wsContent; end else InternalWriteEndElement; FlushData; end; procedure XmlTextWriter.InternalWriteEndElement; var Len: Integer; begin InternalCloseStartTag; Len := Length(FText); if (FText = '') or ((Len >= 2) and (FText[Len] <> #10) and (FText[Len-1] <> #13)) then FText := FText + LineSeparator + IndentStr + '' else FText := FText + ''; FWriteState := wsContent; end; procedure XmlTextWriter.WriteFullEndElement; begin dec(FDepth); InternalWriteEndElement; FlushData; end; procedure XmlTextWriter.WriteString(const Text: string); begin InternalCloseStartTag; FText := FText + Text; FWriteState := wsContent; end; procedure XmlTextWriter.WriteElementString(const LocalName, ns, value: string); begin InternalWriteElementString(LocalName, ns, Value); end; procedure XmlTextWriter.WriteElementString(const LocalName, Value: string); begin InternalWriteElementString(LocalName, '', Value); end; procedure XmlTextWriter.WriteAttributeString(const LocalName, Value: string); begin InternalWriteAttributeString('', LocalName, '', Value); end; procedure XmlTextWriter.WriteAttributeString(const Prefix, LocalName, ns, Value: string); begin if (Prefix <> '') and (ns = '') then raise XmlException.Create('Cannot use a prefix with an empty namespace.'); InternalWriteAttributeString(Prefix, LocalName, ns, Value); end; function XmlTextWriter.IndentStr: string; var i: Integer; begin Result := ''; if (FFormatting = fmtIndented) and (FDepth <> 0) then for i := 1 to FDepth * FIndentation do Result := Result + FIndentChar; end; function XmlTextWriter.PopTagName: string; begin if FTagStack.Count = 0 then raise XmlException.Create('There was no XML start tag open.'); Result := FTagStack[FTagStack.Count-1]; FTagStack.Delete(FTagStack.Count-1); end; procedure XmlTextWriter.PushTagName(const TagName: string); begin FTagStack.Add(TagName); end; procedure XmlTextWriter.InternalCloseStartTag; begin if FWriteState in [wsElement, wsAttribute] then begin FPosStack.Pop; FText := TrimRight(FText); FText := FText + '>'; end; end; { StreamWriter } constructor StreamWriter.Create(const path: string; Append: Boolean); begin inherited Create; if FileExists(path) and Append then begin FWriter := TFileStream.Create(path, fmOpenReadWrite); FWriter.Seek(0, soFromEnd); end else FWriter := TFileStream.Create(path, fmCreate); FReleaseWriter := True; end; constructor StreamWriter.Create(output: TStream; Encoding: EncodingClass); begin inherited Create; FWriter := output; FReleaseWriter := False; FEncodingClass := Encoding; end; destructor StreamWriter.Destroy; begin if FReleaseWriter then FWriter.Free; inherited; end; procedure StreamWriter.Close; begin end; procedure StreamWriter.Flush; begin end; procedure StreamWriter.Write(value: string); var Str: string; begin if FEncodingClass <> nil then begin Str := FEncodingClass.GetString(TBytes(value)); FWriter.Write(PChar(Str)^, Length(Str)); end else FWriter.Write(PChar(value)^, Length(value)); end; procedure StreamWriter.WriteLine(const value: string); begin Write(value + LineSeparator); end; { StreamReader } constructor StreamReader.Create(const path: string; detectEncodingFromByteOrderMarks: Boolean); begin FCapacity := 512; FReader := TFileStream.Create(path, fmOpenRead); FReleaseReader := True; end; constructor StreamReader.Create(input: TStream); begin FCapacity := 512; FReader := input; FReleaseReader := False; end; destructor StreamReader.Destroy; begin if FReleaseReader then FReader.Free; end; function StreamReader.Eof: Boolean; begin Result := FReader.Position = FReader.Size; end; procedure StreamReader.Close; begin end; function StreamReader.ReadToEnd:string; var Len: Int64; begin Len := FReader.Size - FReader.Position; SetLength(Result, Len); Read(TChars(Result), 0, Len); end; function StreamReader.Read(buffer: TChars; Index, Count: Integer):Integer; begin Result := FReader.Read((PChar(buffer) + Index)^, Count); end; function StreamReader.ReadLine:string; var SeparatorPos: Integer; Count, BeginPos: Integer; Position, NextPosition: Int64; begin if Eof then begin Result := ''; exit; end; SetLength(Result, FCapacity); System.FillChar(Result[1], Length(Result), ' '); Position := FReader.Position; Count := 1; SeparatorPos := -1; BeginPos := 1; while True do begin Count := FReader.Read(Result[BeginPos], Length(Result) - BeginPos + 1); SeparatorPos := PosEx(LineSeparator, Result, BeginPos-1); if Eof or (SeparatorPos <> 0) then break; BeginPos := Length(Result)+1; SetLength(Result, BeginPos + Round(BeginPos * 0.3)); System.FillChar(Result[BeginPos], Length(Result) - BeginPos + 1, ' '); end; if SeparatorPos <> 0 then SetLength(Result, SeparatorPos + 1) else SetLength(Result, Count); FCapacity := Length(Result); NextPosition := Position + FCapacity; if (Count <> 0) and (NextPosition + 1 <> FReader.Size) then FReader.Seek(Position - FReader.Position + FCapacity, soFromCurrent); end; { TXmlParser } constructor TXmlParser.Create(const Text: string); begin inherited; FSymbolLexems := XmlSymbolLexems; FKeywordLexems := XmlKeywordLexems; end; { StringReader } constructor StringReader.Create(Text: string); begin FText := Text; end; initialization XmlSymbolLexems := TStringList.Create; XmlKeywordLexems := TStringList.Create; XmlSymbolLexems.AddObject(':', TObject(integer(16))); XmlSymbolLexems.AddObject('=', TObject(integer(19))); XmlSymbolLexems.CustomSort(CRCmpStrings); finalization XmlSymbolLexems.Free; XmlKeywordLexems.Free; end.