Email服务器

开发平台：

Delphi

nativexml.pas：源码内容

function TXmlNode.FromWidestring(const W: widestring): string;
begin
if Utf8Encoded then
Result := sdUnicodeToUtf8(W)
else
Result := W;
end;
function TXmlNode.GetAttributeByName(const AName: string): string;
begin
if assigned(FAttributes) then
Result := UnEscapeString(UnQuoteString(FAttributes.Values[AName]))
else
Result := '';
end;
function TXmlNode.GetAttributeByNameWide(const AName: string): widestring;
begin
Result := ToWidestring(GetAttributeByName(AName));
end;
function TXmlNode.GetAttributeCount: integer;
begin
if assigned(FAttributes) then
Result := FAttributes.Count
else
Result := 0;
end;
function TXmlNode.GetAttributeName(Index: integer): string;
begin
if (Index >= 0) and (Index < AttributeCount) then
Result := FAttributes.Names[Index];
end;
function TXmlNode.GetAttributePair(Index: integer): string;
begin
if (Index >= 0) and (Index < AttributeCount) then
Result := FAttributes[Index];
end;
function TXmlNode.GetAttributeValue(Index: integer): string;
var
P: integer;
S: string;
begin
Result := '';
if (Index >= 0) and (Index < AttributeCount) then begin
S := FAttributes[Index];
P := AnsiPos('=', S);
if P > 0 then
Result := UnEscapeString(UnQuoteString(Copy(S, P + 1, MaxInt)));
end;
end;
function TXmlNode.GetAttributeValueAsInteger(Index: integer): integer;
begin
Result := StrToIntDef(GetAttributeValue(Index), 0);
end;
function TXmlNode.GetAttributeValueAsWidestring(Index: integer): widestring;
begin
Result := ToWidestring(GetAttributeValue(Index));
end;
function TXmlNode.GetBinaryEncoding: TBinaryEncodingType;
begin
Result := xbeBinHex;
if assigned(Document) then
Result := Document.BinaryEncoding;
end;
function TXmlNode.GetBinaryString: string;
// Get the binary contents of this node as Base64 and return it as a string
var
OldEncoding: TBinaryEncodingType;
{$IFDEF CLR}
Buffer: TBytes;
{$ENDIF}
begin
// Set to base64
OldEncoding := BinaryEncoding;
try
BinaryEncoding := xbeBase64;
{$IFDEF CLR}
SetLength(Buffer, BufferLength);
if length(Buffer) > 0 then
BufferRead(Buffer, length(Buffer));
Result := Buffer;
{$ELSE}
SetLength(Result, BufferLength);
if length(Result) > 0 then
BufferRead(Result[1], length(Result));
{$ENDIF}
finally
BinaryEncoding := OldEncoding;
end;
end;
function TXmlNode.GetCascadedName: string;
// Return the name+index and all predecessors with underscores to separate, in
// order to get a unique reference that can be used in filenames
var
AName: string;
begin
AName := Format('%s%.4d', [Name, StrToIntDef(AttributeByName['Index'], 0)]);
if assigned(Parent) then
Result := Format('%s_%s', [Parent.CascadedName, AName])
else
Result := AName;
end;
function TXmlNode.GetFullPath: string;
// GetFullpath will return the complete path of the node from the root, e.g.
// /Root/SubNode1/SubNode2/ThisNode
begin
Result := '/' + Name;
if Treedepth > 0 then
// Recursive call
Result := Parent.GetFullPath + Result;
end;
function TXmlNode.GetIndent: string;
var
i: integer;
begin
if assigned(Document) then
case Document.XmlFormat of
xfCompact: Result := '';
xfReadable:
for i := 0 to TreeDepth - 1 do
Result := Result + Document.IndentString;
end
else
Result := ''
end;
function TXmlNode.GetLineFeed: string;
begin
if assigned(Document) then
case Document.XmlFormat of
xfCompact: Result := '';
xfReadable: Result := #13#10;
else
Result := #10;
end
else
Result := '';
end;
function TXmlNode.GetNodeCount: integer;
begin
if Assigned(FNodes) then
Result := FNodes.Count
else
Result := 0;
end;
function TXmlNode.GetNodes(Index: integer): TXmlNode;
begin
if (Index >= 0) and (Index < NodeCount) then
Result := TXmlNode(FNodes[Index])
else
Result := nil;
end;
function TXmlNode.GetTotalNodeCount: integer;
var
i: integer;
begin
Result := NodeCount;
for i := 0 to NodeCount - 1 do
inc(Result, Nodes[i].TotalNodeCount);
end;
function TXmlNode.GetTreeDepth: integer;
begin
Result := -1;
if assigned(Parent) then
Result := Parent.TreeDepth + 1;
end;
function TXmlNode.GetValueAsBool: boolean;
begin
Result := sdStringToBool(FValue);
end;
function TXmlNode.GetValueAsDateTime: TDateTime;
begin
Result := sdDateTimeFromString(ValueAsString);
end;
function TXmlNode.GetValueAsFloat: double;
var
Code: integer;
begin
val(StringReplace(FValue, ',', '.', []), Result, Code);
if Code > 0 then
raise Exception.Create(sxeCannotConvertToFloat);
end;
function TXmlNode.GetValueAsInt64: int64;
begin
Result := StrToInt64(FValue);
end;
function TXmlNode.GetValueAsInteger: integer;
begin
Result := StrToInt(FValue);
end;
function TXmlNode.GetValueAsString: string;
begin
Result := UnEscapeString(FValue);
end;
function TXmlNode.GetValueAsWidestring: widestring;
begin
Result := ToWidestring(ValueAsString);
end;
function TXmlNode.GetWriteOnDefault: boolean;
begin
Result := True;
if assigned(Document) then
Result := Document.WriteOnDefault;
end;
function TXmlNode.HasAttribute(const AName: string): boolean;
var
i: integer;
begin
Result := False;
for i := 0 to AttributeCount - 1 do
if AnsiCompareText(AName, AttributeName[i]) = 0 then begin
Result := True;
exit;
end;
end;
function TXmlNode.IndexInParent: integer;
// Retrieve our index in the parent's nodelist
var
i: integer;
begin
Result := -1;
if assigned(Parent) then
for i := 0 to Parent.NodeCount - 1 do
if Self = Parent.Nodes[i] then begin
Result := i;
exit;
end;
end;
function TXmlNode.IsClear: boolean;
begin
Result := (Length(FName) = 0) and IsEmpty;
end;
function TXmlNode.IsEmpty: boolean;
begin
Result := (Length(FValue) = 0) and (NodeCount = 0) and (AttributeCount = 0);
end;
function TXmlNode.IsEqualTo(ANode: TXmlNode; Options: TXmlCompareOptions;
MismatchNodes: TList): boolean;
var
i, AIndex: integer;
NodeResult, ChildResult: boolean;
begin
// Start with a negative result
Result := False;
NodeResult := False;
if not assigned(ANode) then exit;
// Assume childs equals other node's childs
ChildResult := True;
// child node names and values - this comes first to assure the lists are filled
if (xcChildNames in Options) or (xcChildValues in Options) or (xcRecursive in Options) then
for i := 0 to NodeCount - 1 do begin
// Do child name check
AIndex := ANode.NodeIndexByName(Nodes[i].Name);
// Do we have the childnode in the other?
if AIndex < 0 then begin
// No we dont have it
if xcChildNames in Options then begin
if assigned(MismatchNodes) then MismatchNodes.Add(Nodes[i]);
ChildResult := False;
end;
end else begin
// Do child value check
if xcChildValues in Options then
if AnsiCompareText(Nodes[i].ValueAsString, ANode.Nodes[AIndex].ValueAsString) <> 0 then begin
if assigned(MismatchNodes) then MismatchNodes.Add(Nodes[i]);
ChildResult := False;
end;
// Do recursive check
if xcRecursive in Options then
if not Nodes[i].IsEqualTo(ANode.Nodes[AIndex], Options, MismatchNodes) then
ChildResult := False;
end;
end;
try
// We assume there are differences
NodeResult := False;
// Node name, type and value
if xcNodeName in Options then
if AnsiCompareText(Name, ANode.Name) <> 0 then exit;
if xcNodeType in Options then
if ElementType <> ANode.ElementType then exit;
if xcNodeValue in Options then
if AnsiCompareText(ValueAsString, ANode.ValueAsString) <> 0 then exit;
// attribute count
if xcAttribCount in Options then
if AttributeCount <> ANode.AttributeCount then exit;
// attribute names and values
if (xcAttribNames in Options) or (xcAttribValues in Options) then
for i := 0 to AttributeCount - 1 do begin
AIndex := ANode.AttributeIndexByName(AttributeName[i]);
if AIndex < 0 then
if xcAttribNames in Options then
exit
else
continue;
if xcAttribValues in Options then
if AnsiCompareText(AttributeValue[i], ANode.AttributeValue[AIndex]) <> 0 then
exit;
end;
// child node count
if xcChildCount in Options then
if NodeCount <> ANode.NodeCount then exit;
// If we arrive here, it means no differences were found, return True
NodeResult := True;
finally
Result := ChildResult and NodeResult;
if (not NodeResult) and assigned(MismatchNodes) then
MismatchNodes.Insert(0, Self);
end;
end;
function TXmlNode.NodeAdd(ANode: TXmlNode): integer;
begin
if assigned(ANode) then begin
ANode.Parent := Self;
if not assigned(FNodes) then FNodes := TList.Create;
Result := FNodes.Add(ANode);
end else
Result := -1;
end;
function TXmlNode.NodeByAttributeValue(const NodeName, AttribName, AttribValue: string;
ShouldRecurse: boolean): TXmlNode;
// This function returns a pointer to the first subnode that has an attribute with
// name AttribName and value AttribValue.
var
i: integer;
ANode: TXmlNode;
begin
Result := nil;
// Find all nodes that are potential results
for i := 0 to NodeCount - 1 do begin
ANode := Nodes[i];
if (AnsiCompareText(ANode.Name, NodeName) = 0) and
ANode.HasAttribute(AttribName) and
(AnsiCompareText(ANode.AttributeByName[AttribName], AttribValue) = 0) then begin
Result := ANode;
exit;
end;
// Recursive call
if ShouldRecurse then
Result := ANode.NodeByAttributeValue(NodeName, AttribName, AttribValue, True);
if assigned(Result) then exit;
end;
end;
function TXmlNode.NodeByElementType(
ElementType: TXmlElementType): TXmlNode;
var
i: integer;
begin
Result := nil;
for i := 0 to NodeCount - 1 do
if Nodes[i].ElementType = ElementType then begin
Result := Nodes[i];
exit;
end;
end;
function TXmlNode.NodeByName(const AName: string): TXmlNode;
var
i: integer;
begin
Result := nil;
for i := 0 to NodeCount - 1 do
if AnsiCompareText(Nodes[i].Name, AName) = 0 then begin
Result := Nodes[i];
exit;
end;
end;
procedure TXmlNode.NodeDelete(Index: integer);
begin
if (Index >= 0) and (Index < NodeCount) then begin
TXmlNode(FNodes[Index]).Free;
FNodes.Delete(Index);
end;
end;
procedure TXmlNode.NodeExchange(Index1, Index2: integer);
begin
if (Index1 >= 0) and (Index1 < Nodecount) and
(Index2 >= 0) and (Index2 < Nodecount) then
FNodes.Exchange(Index1, Index2);
end;
function TXmlNode.NodeExtract(ANode: TXmlNode): TXmlNode;
var
AIndex: integer;
begin
// Compatibility with Delphi4
Result := nil;
if assigned(FNodes) then begin
AIndex := FNodes.IndexOf(ANode);
if AIndex >= 0 then begin
Result := ANode;
FNodes.Delete(AIndex);
end;
end;
end;
function TXmlNode.NodeFindOrCreate(const AName: string): TXmlNode;
// Find the node with AName, and if not found, add new one
begin
Result := NodeByName(AName);
if not assigned(Result) then
Result := NodeNew(AName);
end;
function TXmlNode.NodeIndexByName(const AName: string): integer;
begin
Result := 0;
while Result < NodeCount do begin
if AnsiCompareText(Nodes[Result].Name, AName) = 0 then exit;
inc(Result);
end;
if Result = NodeCount then Result := -1;
end;
function TXmlNode.NodeIndexByNameFrom(const AName: string;
AFrom: integer): integer;
begin
Result := AFrom;
while Result < NodeCount do begin
if AnsiCompareText(Nodes[Result].Name, AName) = 0 then exit;
inc(Result);
end;
if Result = NodeCount then Result := -1;
end;
function TXmlNode.NodeIndexOf(ANode: TXmlNode): integer;
begin
if assigned(ANode) and assigned(FNodes) then
Result := FNodes.IndexOf(ANode)
else
Result := -1;
end;
procedure TXmlNode.NodeInsert(Index: integer; ANode: TXmlNode);
// Insert the node ANode at location Index in the list.
begin
if not assigned(ANode) then exit;
if (Index >=0) and (Index <= NodeCount) then begin
if not assigned(FNodes) then FNodes := TList.Create;
ANode.Parent := Self;
FNodes.Insert(Index, ANode);
end;
end;
function TXmlNode.NodeNew(const AName: string): TXmlNode;
// Add a new child node and return its pointer
begin
Result := Nodes[NodeAdd(TXmlNode.CreateName(Document, AName))];
end;
function TXmlNode.NodeNewAtIndex(Index: integer;
const AName: string): TXmlNode;
// Create a new node with AName, and insert it into the subnode list at location
// Index, and return a pointer to it.
begin
if (Index >= 0) and (Index <= NodeCount) then begin
Result := TXmlNode.CreateName(Document, AName);
NodeInsert(Index, Result);
end else
Result := nil;
end;
function TXmlNode.NodeRemove(ANode: TxmlNode): integer;
begin
Result := NodeIndexOf(ANode);
if Result >= 0 then
NodeDelete(Result);
end;
procedure TXmlNode.NodesByName(const AName: string; const AList: TList);
// Fill AList with nodes that have name AName
var
i: integer;
begin
if not assigned(AList) then exit;
AList.Clear;
for i := 0 to NodeCount - 1 do
if AnsiCompareText(Nodes[i].Name, AName) = 0 then
AList.Add(Nodes[i]);
end;
procedure TXmlNode.NodesClear;
var
i: integer;
begin
for i := 0 to NodeCount - 1 do
TXmlNode(FNodes[i]).Free;
FreeAndNil(FNodes);
end;
procedure TXmlNode.ParseTag(const AValue: string; TagStart,
TagClose: integer);
var
FItems: TStringList;
begin
// Create a list to hold string items
FItems := TStringList.Create;
try
ParseAttributes(AValue, TagStart, TagClose, FItems);
// Determine name, attributes or value for each element type
case ElementType of
xeDeclaration:
FName := 'xml';
xeStyleSheet:
begin
FName := 'xml-stylesheet';
// We also set this as the value for use in "StyleSheetString"
ValueDirect := trim(copy(AValue, TagStart, TagClose - TagStart));
end;
else
// First item is the name - is it there?
if FItems.Count = 0 then
raise EFilerError.Create(sxeMissingElementName);
// Set the name - using the element instead of property for speed
FName := FItems[0];
FItems.Delete(0);
end;//case
// Any attributes?
if FItems.Count > 0 then begin
CheckCreateAttributesList;
FAttributes.Assign(FItems);
end;
finally
FItems.Free;
end;
end;
function TXmlNode.QualifyAsDirectNode: boolean;
// If this node qualifies as a direct node when writing, we return True.
// A direct node may have attributes, but no value or subnodes. Furhtermore,
// the root node will never be displayed as a direct node.
begin
Result :=
(Length(FValue) = 0) and
(NodeCount = 0) and
(ElementType = xeNormal) and
not UseFullNodes and
(TreeDepth > 0);
end;
function TXmlNode.ReadAttributeBool(const AName: string;
ADefault: boolean): boolean;
var
AValue: string;
begin
AValue := AttributeByName[AName];
try
Result := sdStringToBool(AValue);
except
Result := ADefault;
end;
end;
function TXmlNode.ReadAttributeFloat(const AName: string;
ADefault: double): double;
var
AValue: string;
Code: integer;
begin
AValue := AttributeByName[AName];
val(StringReplace(AValue, ',', '.', []), Result, Code);
if Code > 0 then
Result := ADefault;
end;
function TXmlNode.ReadAttributeInteger(const AName: string;
ADefault: integer): integer;
begin
Result := StrToIntDef(AttributeByName[AName], ADefault);
end;
function TXmlNode.ReadAttributeInt64(const AName: string;
ADefault: int64): int64;
begin
Result := StrToInt64Def(AttributeByName[AName], ADefault);
end;
function TXmlNode.ReadAttributeString(const AName: string; const ADefault: string): string;
begin
Result := AttributeByName[AName];
if length(Result) = 0 then
Result := ADefault;
end;
function TXmlNode.ReadBool(const AName: string;
ADefault: boolean): boolean;
var
AIndex: integer;
begin
Result := ADefault;
AIndex := NodeIndexByName(AName);
if AIndex >= 0 then
Result := Nodes[AIndex].ValueAsBoolDef(ADefault);
end;
{$IFDEF USEGRAPHICS}
procedure TXmlNode.ReadBrush(const AName: string; ABrush: TBrush);
var
AChild: TXmlNode;
begin
AChild := NodeByName(AName);
if assigned(AChild) then with AChild do begin
// Read values
ABrush.Color := ReadColor('Color', clWhite);
ABrush.Style := TBrushStyle(ReadInteger('Style', integer(bsSolid)));
end else begin
// Defaults
ABrush.Bitmap := nil;
ABrush.Color := clWhite;
ABrush.Style := bsSolid;
end;
end;
function TXmlNode.ReadColor(const AName: string; ADefault: TColor): TColor;
var
AIndex: integer;
begin
Result := ADefault;
AIndex := NodeIndexByName(AName);
if AIndex >= 0 then
Result := StrToInt(Nodes[AIndex].ValueAsString);
end;
{$ENDIF}
function TXmlNode.ReadDateTime(const AName: string;
ADefault: TDateTime): TDateTime;
// Date MUST always be written in this format:
// YYYY-MM-DD (if just date) or
// YYYY-MM-DDThh:mm:ss.sssZ (if date and time. The Z stands for universal time
// zone. Since Delphi's TDateTime does not give us a clue about the timezone,
// this is the easiest solution)
// This format SHOULD NOT be changed, to avoid all kinds of
// conversion errors in future.
// This format is compatible with the W3C date/time specification as found here:
// http://www.w3.org/TR/NOTE-datetime
begin
Result := sdDateTimeFromStringDefault(ReadString(AName, ''), ADefault);
end;
function TXmlNode.ReadFloat(const AName: string; ADefault: double): double;
var
AIndex: integer;
begin
Result := ADefault;
AIndex := NodeIndexByName(AName);
if AIndex >= 0 then
Result := Nodes[AIndex].ValueAsFloatDef(ADefault);
end;
{$IFDEF USEGRAPHICS}
procedure TXmlNode.ReadFont(const AName: string; AFont: TFont);
var
AChild: TXmlNode;
begin
AChild := NodeByName(AName);
AFont.Style := [];
if assigned(AChild) then with AChild do begin
// Read values
AFont.Name := ReadString('Name', 'Arial');
AFont.Color := ReadColor('Color', clBlack);
AFont.Size := ReadInteger('Size', 14);
if ReadBool('Bold', False) then AFont.Style := AFont.Style + [fsBold];
if ReadBool('Italic', False) then AFont.Style := AFont.Style + [fsItalic];
if ReadBool('Underline', False) then AFont.Style := AFont.Style + [fsUnderline];
if ReadBool('Strikeout', False) then AFont.Style := AFont.Style + [fsStrikeout];
end else begin
// Defaults
AFont.Name := 'Arial';
AFont.Color := clBlack;
AFont.Size := 14;
end;
end;
{$ENDIF}
procedure TXmlNode.ReadFromStream(S: TStream);
// Read the node from the starting "<" until the closing ">" from the stream in S.
// This procedure also calls OnNodeNew and OnNodeLoaded events
var
Ch: Char;
i: integer;
ATagIndex: integer;
AValue: string;
ALength: integer;
ANode: TXmlNode;
ANodeValue: string;
AValuePos, AValueLength: integer;
AClose: integer;
HasCR: boolean;
HasSubtags: boolean;
Words: TStringList;
IsDirect: boolean;
Reader: TsdSurplusReader;
// local
procedure AddCharDataNode;
var
AValue: string;
ANode: TXmlNode;
begin
// Add all text up till now as xeCharData
if AValuePos > 0 then begin
AValue := copy(ANodeValue, 1, AValuePos);
if length(trim(AValue)) > 0 then begin
ANode := TXmlNode.CreateType(Document, xeCharData);
ANode.ValueDirect := AValue;
NodeAdd(ANode);
end;
AValuePos := 0;
end;
end;
// Main
begin
// Check if we aborted parsing
if assigned(Document) and Document.AbortParsing then exit;
// Initial reserve textual value: just 80 characters which is OK for most short values
AValuePos := 0;
AValueLength := 80;
SetLength(ANodeValue, AValueLength);
HasCR := False;
HasSubTags := False;
Reader := TsdSurplusReader.Create(S);
try
// Trailing blanks/controls chars?
if not Reader.ReadCharSkipBlanks(Ch) then exit;
// What is it?
if Ch = '<' then begin
// A tag - which one?
ATagIndex := ReadOpenTag(Reader);
if ATagIndex >= 0 then begin
try
ElementType := cTags[ATagIndex].FStyle;
case ElementType of
xeNormal, xeDeclaration, xeStyleSheet:
begin
// These tags we will process
ReadStringFromStreamUntil(Reader, cTags[ATagIndex].FClose, AValue, True);
ALength := length(AValue);
// Is it a direct tag?
IsDirect := False;
if (ElementType = xeNormal) and (ALength > 0) then
if AValue[ALength] = '/' then begin
dec(ALength);
IsDirect := True;
end;
ParseTag(AValue, 1, ALength + 1);
// Here we know our name so good place to call OnNodeNew event
if assigned(Document) then begin
Document.DoNodeNew(Self);
if Document.AbortParsing then exit;
end;
// Now the tag can be a direct close - in that case we're finished
if IsDirect or (ElementType in [xeDeclaration, xeStyleSheet]) then exit;
// Process rest of tag
repeat
// Read character from stream
if S.Read(Ch, 1) <> 1 then
raise EFilerError.CreateFmt(sxeMissingCloseTag, [Name]);
// Is there a subtag?
if Ch = '<' then begin
if not Reader.ReadCharSkipBlanks(Ch) then
raise EFilerError.CreateFmt(sxeMissingDataAfterGreaterThan, [Name]);
if Ch = '/' then begin
// This seems our closing tag
if not ReadStringFromStreamUntil(Reader, '>', AValue, True) then
raise EFilerError.CreateFmt(sxeMissingLessThanInCloseTag, [Name]);
if AnsiCompareText(trim(AValue), Name) <> 0 then
raise EFilerError.CreateFmt(sxeIncorrectCloseTag, [Name]);
AValue := '';
break;
end else begin
// Add all text up till now as xeCharData
AddCharDataNode;
// Reset the HasCR flag if we add node, we only want to detect
// the CR after last subnode
HasCR := False;
// This is a subtag... so create it and let it process
HasSubTags := True;
S.Seek(-2, soCurrent);
ANode := TXmlNode.Create(Document);
NodeAdd(ANode);
ANode.ReadFromStream(S);
// Check for dropping comments
if assigned(Document) and Document.DropCommentsOnParse and
(ANode.ElementType = xeComment) then
NodeDelete(NodeIndexOf(ANode));
end;
end else begin
// If we detect a CR we will set the flag. This will signal the fact
// that this XML file was saved with xfReadable
if Ch = #13 then HasCR := True;
// Add the character to the node value buffer.
inc(AValuePos);
if AValuePos > AValueLength then begin
inc(AValueLength, cNodeValueBuf);
SetLength(ANodeValue, AValueLength);
end;
ANodeValue[AValuePos] := Ch;
end;
until False;
// Add all text up till now as xeText
AddCharDataNode;
// Check CharData nodes, remove trailing CRLF + indentation if we
// were in xfReadable mode
if HasSubtags and HasCR then begin
for i := 0 to NodeCount - 1 do
if Nodes[i].ElementType = xeCharData then begin
AClose := length(Nodes[i].FValue);
while (AClose > 0) and (Nodes[i].FValue[AClose] in [#10, #13, ' ']) do
dec(AClose);
Nodes[i].FValue := copy(Nodes[i].FValue, 1, AClose);
end;
end;
// If the first node is xeCharData we use it as ValueDirect
if NodeCount > 0 then
if Nodes[0].ElementType = xeCharData then begin
ValueDirect := Nodes[0].ValueDirect;
NodeDelete(0);
end;
end;
xeDocType:
begin
Name := 'DTD';
if assigned(Document) then begin
Document.DoNodeNew(Self);
if Document.AbortParsing then exit;
end;
// Parse DTD
if assigned(Document) then Document.ParseDTD(Self, S);
end;
xeElement, xeAttList, xeEntity, xeNotation:
begin
// DTD elements
ReadStringFromStreamWithQuotes(S, cTags[ATagIndex].FClose, AValue);
ALength := length(AValue);
Words := TStringList.Create;
try
ParseAttributes(AValue, 1, ALength + 1, Words);
if Words.Count > 0 then begin
Name := Words[0];
Words.Delete(0);
end;
ValueDirect := trim(Words.Text);
finally
Words.Free;
end;
if assigned(Document) then begin
Document.DoNodeNew(Self);
if Document.AbortParsing then exit;
end;
end;
else
case ElementType of
xeComment: Name := 'Comment';
xeCData: Name := 'CData';
xeExclam: Name := 'Special';
xeQuestion: Name := 'Special';
else
Name := 'Unknown';
end;
// Here we know our name so good place to call OnNodeNew
if assigned(Document) then begin
Document.DoNodeNew(Self);
if Document.AbortParsing then exit;
end;
// In these cases just get all data up till the closing tag
ReadStringFromStreamUntil(Reader, cTags[ATagIndex].FClose, AValue, False);
ValueDirect := AValue;
end;//case
finally
// Call the OnNodeLoaded and OnProgress events
if assigned(Document) and not Document.AbortParsing then begin
Document.DoProgress(S.Position);
Document.DoNodeLoaded(Self);
end;
end;
end;
end;
finally
Reader.Free;
end;
end;
procedure TXmlNode.ReadFromString(const AValue: string);
var
S: TStream;
begin
S := TsdStringStream.Create(AValue);
try
ReadFromStream(S);
finally
S.Free;
end;
end;
{$IFDEF D4UP}
function TXmlNode.ReadInt64(const AName: string; ADefault: int64): int64;
var
AIndex: integer;
begin
Result := ADefault;
AIndex := NodeIndexByName(AName);
if AIndex >= 0 then
Result := Nodes[AIndex].ValueAsInt64Def(ADefault);
end;
{$ENDIF}
function TXmlNode.ReadInteger(const AName: string; ADefault: integer): integer;
var
AIndex: integer;
begin
Result := ADefault;
AIndex := NodeIndexByName(AName);
if AIndex >= 0 then
Result := Nodes[AIndex].ValueAsIntegerDef(ADefault);
end;
{$IFDEF USEGRAPHICS}
procedure TXmlNode.ReadPen(const AName: string; APen: TPen);
var
AChild: TXmlNode;
begin
AChild := NodeByName(AName);
if assigned(AChild) then with AChild do begin
// Read values
APen.Color := ReadColor('Color', clBlack);
APen.Mode := TPenMode(ReadInteger('Mode', integer(pmCopy)));
APen.Style := TPenStyle(ReadInteger('Style', integer(psSolid)));
APen.Width := ReadInteger('Width', 1);
end else begin
// Defaults
APen.Color := clBlack;
APen.Mode := pmCopy;
APen.Style := psSolid;
APen.Width := 1;
end;
end;
{$ENDIF}
function TXmlNode.ReadString(const AName: string;
const ADefault: string): string;
var
AIndex: integer;
begin
Result := ADefault;
AIndex := NodeIndexByName(AName);
if AIndex >= 0 then
Result := Nodes[AIndex].ValueAsString;
end;
function TXmlNode.ReadWidestring(const AName: string;
const ADefault: widestring): widestring;
begin
Result := ToWidestring(ReadString(AName, FromWidestring(ADefault)));
end;
procedure TXmlNode.ResolveEntityReferences;
// Replace any entity references by the entities, and parse the new content if any
// local
function SplitReference(const AValue: string; var Text1, Text2: string): string;
var
APos: integer;
begin
Result := '';
APos := Pos('&', AValue);
Text1 := '';
Text2 := AValue;
if APos = 0 then exit;
Text1 := copy(AValue, 1, APos - 1);
Text2 := copy(AValue, APos + 1, length(AValue));
APos := Pos(';', Text2);
if APos = 0 then exit;
Result := copy(Text2, 1, APos - 1);
Text2 := copy(Text2, APos + 1, length(Text2));
end;
// local
function ReplaceEntityReferenceByNodes(ARoot: TXmlNode; const AValue: string; var InsertPos: integer; var Text1, Text2: string): boolean;
var
Reference: string;
Entity: string;
ANode: TXmlNode;
S: TStream;
begin
Result := False;
Reference := SplitReference(AValue, Text1, Text2);
if (length(Reference) = 0) or not assigned(Document) then exit;
// Lookup entity references
Entity := Document.EntityByName[Reference];
// Does the entity contain markup?
if (length(Entity) > 0) and (Pos('<', Entity) > 0) then begin
S := TsdStringStream.Create(Entity);
try
while S.Position < S.Size do begin
ANode := TXmlNode.Create(Document);
ANode.ReadFromStream(S);
if ANode.IsEmpty then
ANode.Free
else begin
ARoot.NodeInsert(InsertPos, ANode);
inc(InsertPos);
Result := True;
end;
end;
finally
S.Free;
end;
end;
end;
// main
var
i: integer;
InsertPos: integer;
Text1, Text2: string;
ANode: TXmlNode;
AValue, Reference, Replace, Entity, First, Last: string;
begin
if length(FValue) > 0 then begin
// Different behaviour for xeNormal and xeCharData
if ElementType = xeNormal then begin
InsertPos := 0;
if ReplaceEntityReferenceByNodes(Self, FValue, InsertPos, Text1, Text2) then begin
FValue := Text1;
if length(trim(Text2)) > 0 then begin
ANode := TXmlNode.CreateType(Document, xeCharData);
ANode.ValueDirect := Text2;
NodeInsert(InsertPos, ANode);
end;
end;
end else if (ElementType = xeCharData) and assigned(Parent) then begin
InsertPos := Parent.NodeIndexOf(Self);
if ReplaceEntityReferenceByNodes(Parent, FValue, InsertPos, Text1, Text2) then begin
FValue := Text1;
if length(trim(FValue)) = 0 then FValue := '';
if length(trim(Text2)) > 0 then begin
ANode := TXmlNode.CreateType(Document, xeCharData);
ANode.ValueDirect := Text2;
Parent.NodeInsert(InsertPos, ANode);
end;
end;
end;
end;
// Do attributes
for i := 0 to AttributeCount - 1 do begin
Last := AttributeValue[i];
AValue := '';
repeat
Reference := SplitReference(Last, First, Last);
Replace := '';
if length(Reference) > 0 then begin
Entity := Document.EntityByName[Reference];
if length(Entity) > 0 then
Replace := Entity
else
Replace := '&' + Reference + ';';
end;
AValue := AValue + First + Replace;
until length(Reference) = 0;
AValue := AValue + Last;
AttributeValue[i] := AValue;
end;
// Do childnodes too
i := 0;
while i < NodeCount do begin
Nodes[i].ResolveEntityReferences;
inc(i);
end;
// Check for empty CharData nodes
for i := NodeCount - 1 downto 0 do
if (Nodes[i].ElementType = xeCharData) and (length(Nodes[i].ValueDirect) = 0) then
NodeDelete(i);
end;
procedure TXmlNode.SetAttributeByName(const AName, Value: string);
begin
CheckCreateAttributesList;
FAttributes.Values[AName] := QuoteString(EscapeString(Value));
end;
procedure TXmlNode.SetAttributeByNameWide(const AName: string; const Value: widestring);
begin
SetAttributeByName(AName, FromWidestring(Value));
end;
procedure TXmlNode.SetAttributeName(Index: integer; const Value: string);
var
S: string;
P: integer;
begin
if (Index >= 0) and (Index < AttributeCount) then begin
S := FAttributes[Index];
P := AnsiPos('=', S);
if P > 0 then
FAttributes[Index] := Format('%s=%s', [Value, Copy(S, P + 1, MaxInt)]);
end;
end;
procedure TXmlNode.SetAttributeValue(Index: integer; const Value: string);
begin
if (Index >= 0) and (Index < AttributeCount) then
FAttributes[Index] := Format('%s=%s', [AttributeName[Index],
QuoteString(EscapeString(Value))]);
end;
procedure TXmlNode.SetAttributeValueAsInteger(Index: integer;
const Value: integer);
begin
SetAttributeValue(Index, IntToStr(Value));
end;
procedure TXmlNode.SetAttributeValueAsWidestring(Index: integer;
const Value: widestring);
begin
SetAttributeValue(Index, FromWidestring(Value));
end;
procedure TXmlNode.SetBinaryEncoding(const Value: TBinaryEncodingType);
begin
if assigned(Document) then
Document.BinaryEncoding := Value;
end;
procedure TXmlNode.SetBinaryString(const Value: string);
var
OldEncoding: TBinaryEncodingType;
begin
// Set to base64
OldEncoding := BinaryEncoding;
try
BinaryEncoding := xbeBase64;
if length(Value) = 0 then begin
ValueAsString := '';
exit;
end;
// fill the buffer
{$IFDEF CLR}
BufferWrite(BytesOf(Value), length(Value));
{$ELSE}
BufferWrite(Value[1], length(Value));
{$ENDIF}
finally
BinaryEncoding := OldEncoding;
end;
end;
procedure TXmlNode.SetName(const Value: string);
var
i: integer;
begin
if FName <> Value then begin
// Check if the name abides the rules. We will be very forgiving here and
// just accept any name that at least does not contain control characters
for i := 1 to length(Value) do
if Value[i] in cControlChars then
raise Exception.Create(Format(sxeIllegalCharInNodeName, [Value]));
FName := Value;
end;
end;
procedure TXmlNode.SetValueAsBool(const Value: boolean);
begin
FValue := sdStringFromBool(Value);
end;
procedure TXmlNode.SetValueAsDateTime(const Value: TDateTime);
begin
ValueAsString := sdDateTimeToString(Value);
end;
procedure TXmlNode.SetValueAsFloat(const Value: double);
begin
FValue := sdWriteNumber(Value, FloatSignificantDigits, FloatAllowScientific);
end;
procedure TXmlNode.SetValueAsInt64(const Value: int64);
begin
FValue := IntToStr(Value);
end;
procedure TXmlNode.SetValueAsInteger(const Value: integer);
begin
FValue := IntToStr(Value);
end;
procedure TXmlNode.SetValueAsString(const AValue: string);
begin
FValue := EscapeString(AValue);
end;
procedure TXmlNode.SetValueAsWidestring(const Value: widestring);
begin
ValueAsString := FromWidestring(Value);
end;
procedure TXmlNode.SortChildNodes(Compare: TXMLNodeCompareFunction;
Info: TPointer);
// Sort the child nodes using the quicksort algorithm
//local
function DoNodeCompare(Node1, Node2: TXmlNode): integer;
begin
if assigned(Compare) then
Result := Compare(Node1, Node2, Info)
else
if assigned(Document) and assigned(Document.OnNodeCompare) then
Result := Document.OnNodeCompare(Document, Node1, Node2, Info)
else
Result := AnsiCompareText(Node1.Name, Node2.Name);
end;
// local
procedure QuickSort(iLo, iHi: Integer);
var
Lo, Hi, Mid: longint;
begin
Lo := iLo;
Hi := iHi;
Mid:= (Lo + Hi) div 2;
repeat
while DoNodeCompare(Nodes[Lo], Nodes[Mid]) < 0 do
Inc(Lo);
while DoNodeCompare(Nodes[Hi], Nodes[Mid]) > 0 do
Dec(Hi);
if Lo <= Hi then begin
// Swap pointers;
NodeExchange(Lo, Hi);
if Mid = Lo then
Mid := Hi
else
if Mid = Hi then
Mid := Lo;
Inc(Lo);
Dec(Hi);
end;
until Lo > Hi;
if Hi > iLo then QuickSort(iLo, Hi);
if Lo < iHi then QuickSort(Lo, iHi);
end;
// main
begin
if NodeCount > 1 then
QuickSort(0, NodeCount - 1);
end;
function TXmlNode.ToAnsiString(const s: string): string;
begin
if Utf8Encoded then
Result := sdUtf8ToAnsi(s)
else
Result := s;
end;
function TXmlNode.ToWidestring(const s: string): widestring;
begin
if Utf8Encoded then
Result := sdUtf8ToUnicode(s)
else
Result := s;
end;
function TXmlNode.UnescapeString(const AValue: string): string;
begin
if Utf8Encoded then
Result := UnescapeStringUTF8(AValue)
else
Result := UnescapeStringAnsi(AValue);
end;
function TXmlNode.UseFullNodes: boolean;
begin
Result := False;
if assigned(Document) then Result := Document.UseFullNodes;
end;
function TXmlNode.Utf8Encoded: boolean;
begin
Result := False;
if assigned(Document) then
Result := Document.Utf8Encoded;
end;
function TXmlNode.ValueAsBoolDef(ADefault: boolean): boolean;
var
Ch: Char;
begin
Result := ADefault;
if Length(FValue) = 0 then exit;
Ch := UpCase(FValue[1]);
if Ch in ['T', 'Y'] then begin
Result := True;
exit;
end;
if Ch in ['F', 'N'] then begin
Result := False;
exit;
end;
end;
function TXmlNode.ValueAsDateTimeDef(ADefault: TDateTime): TDateTime;
begin
Result := sdDateTimeFromStringDefault(ValueAsString, ADefault);
end;
function TXmlNode.ValueAsFloatDef(ADefault: double): double;
var
Code: integer;
begin
try
val(StringReplace(FValue, ',', '.', []), Result, Code);
if Code > 0 then
Result := ADefault;
except
Result := ADefault;
end;
end;
function TXmlNode.ValueAsInt64Def(ADefault: int64): int64;
begin
Result := StrToInt64Def(FValue, ADefault);
end;
function TXmlNode.ValueAsIntegerDef(ADefault: integer): integer;
begin
Result := StrToIntDef(FValue, ADefault);
end;
procedure TXmlNode.WriteAttributeBool(const AName: string; AValue: boolean;
ADefault: boolean);
var
AIndex: integer;
begin
if WriteOnDefault or (AValue <> ADefault) then begin
AIndex := AttributeIndexByName(AName);
if AIndex >= 0 then
AttributeValue[AIndex] := sdStringFromBool(AValue)
else
AttributeAdd(AName, sdStringFromBool(AValue));
end;
end;
procedure TXmlNode.WriteAttributeFloat(const AName: string; AValue, ADefault: double);
var
AIndex: integer;
S: string;
begin
if WriteOnDefault or (AValue <> ADefault) then begin
AIndex := AttributeIndexByName(AName);
S := sdWriteNumber(AValue, FloatSignificantDigits, FloatAllowScientific);
if AIndex >= 0 then
AttributeValue[AIndex] := S
else
AttributeAdd(AName, S);
end;
end;
procedure TXmlNode.WriteAttributeInteger(const AName: string; AValue: integer; ADefault: integer);
var
AIndex: integer;
begin
if WriteOnDefault or (AValue <> ADefault) then begin
AIndex := AttributeIndexByName(AName);
if AIndex >= 0 then
AttributeValue[AIndex] := IntToStr(AValue)
else
AttributeAdd(AName, IntToStr(AValue));
end;
end;
procedure TXmlNode.WriteAttributeString(const AName, AValue,
ADefault: string);
var
AIndex: integer;
begin
if WriteOnDefault or (AValue <> ADefault) then begin
AIndex := AttributeIndexByName(AName);
if AIndex >= 0 then
AttributeValue[AIndex] := AValue
else
AttributeAdd(AName, AValue);
end;
end;
procedure TXmlNode.WriteBool(const AName: string; AValue: boolean; ADefault: boolean);
const
cBoolValues: array[boolean] of string = ('False', 'True');
begin
if WriteOnDefault or (AValue <> ADefault) then
with NodeFindOrCreate(AName) do
ValueAsString := cBoolValues[AValue];
end;
{$IFDEF USEGRAPHICS}
procedure TXmlNode.WriteBrush(const AName: string; ABrush: TBrush);
begin
with NodeFindOrCreate(AName) do begin
WriteColor('Color', ABrush.Color, clBlack);
WriteInteger('Style', integer(ABrush.Style), 0);
end;
end;
procedure TXmlNode.WriteColor(const AName: string; AValue, ADefault: TColor);
begin
if WriteOnDefault or (AValue <> ADefault) then
WriteHex(AName, ColorToRGB(AValue), 8, 0);
end;
{$ENDIF}
procedure TXmlNode.WriteDateTime(const AName: string; AValue,
ADefault: TDateTime);
// Date MUST always be written in this format:
// YYYY-MM-DD (if just date) or
// YYYY-MM-DDThh:mm:ss.sssZ (if date and time. The Z stands for universal time
// zone. Since Delphi's TDateTime does not give us a clue about the timezone,
// this is the easiest solution)
// This format SHOULD NOT be changed, to avoid all kinds of
// conversion errors in future.
// This format is compatible with the W3C date/time specification as found here:
// http://www.w3.org/TR/NOTE-datetime
begin
if WriteOnDefault or (AValue <> ADefault) then
WriteString(AName, sdDateTimeToString(AValue), '');
end;
procedure TXmlNode.WriteFloat(const AName: string; AValue: double; ADefault: double);
begin
if WriteOnDefault or (AValue <> ADefault) then
with NodeFindOrCreate(AName) do
ValueAsString := sdWriteNumber(AValue, FloatSignificantDigits, FloatAllowScientific);
end;
{$IFDEF USEGRAPHICS}
procedure TXmlNode.WriteFont(const AName: string; AFont: TFont);
begin
with NodeFindOrCreate(AName) do begin
WriteString('Name', AFont.Name, 'Arial');
WriteColor('Color', AFont.Color, clBlack);
WriteInteger('Size', AFont.Size, 14);
WriteBool('Bold', fsBold in AFont.Style, False);
WriteBool('Italic', fsItalic in AFont.Style, False);
WriteBool('Underline', fsUnderline in AFont.Style, False);
WriteBool('Strikeout', fsStrikeout in AFont.Style, False);
end;
end;
{$ENDIF}
procedure TXmlNode.WriteHex(const AName: string; AValue, Digits: integer; ADefault: integer);
begin
if WriteOnDefault or (AValue <> ADefault) then
with NodeFindOrCreate(AName) do
ValueAsString := '$' + IntToHex(AValue, Digits);
end;
function TXmlNode.WriteInnerTag: string;
// Write the inner part of the tag, the one that contains the attributes
var
i: integer;
begin
Result := '';
// Attributes
for i := 0 to AttributeCount - 1 do
// Here we used to prevent empty attributes, but in fact, empty attributes
// should be allowed because sometimes they're required
Result := Result + ' ' + AttributePair[i];
// End of tag - direct nodes get an extra "/"
if QualifyAsDirectNode then
Result := Result + '/';
end;
{$IFDEF D4UP}
procedure TXmlNode.WriteInt64(const AName: string; AValue, ADefault: int64);
begin
if WriteOnDefault or (AValue <> ADefault) then
with NodeFindOrCreate(AName) do
ValueAsString := IntToStr(AValue);
end;
{$ENDIF}
procedure TXmlNode.WriteInteger(const AName: string; AValue: integer; ADefault: integer);
begin
if WriteOnDefault or (AValue <> ADefault) then
with NodeFindOrCreate(AName) do
ValueAsString := IntToStr(AValue);
end;
{$IFDEF USEGRAPHICS}
procedure TXmlNode.WritePen(const AName: string; APen: TPen);
begin
with NodeFindOrCreate(AName) do begin
WriteColor('Color', APen.Color, clBlack);
WriteInteger('Mode', integer(APen.Mode), 0);
WriteInteger('Style', integer(APen.Style), 0);
WriteInteger('Width', APen.Width, 0);
end;
end;
{$ENDIF}
procedure TXmlNode.WriteString(const AName, AValue: string; const ADefault: string);
begin
if WriteOnDefault or (AValue <> ADefault) then
with NodeFindOrCreate(AName) do
ValueAsString := AValue;
end;
procedure TXmlNode.WriteToStream(S: TStream);
var
i: integer;
AIndent: string;
ALineFeed: string;
ALine: string;
ThisNode, NextNode: TXmlNode;
AddLineFeed: boolean;
begin
AIndent := GetIndent;
ALineFeed := GetLineFeed;
// Write indent
ALine := AIndent;
// Write the node - distinguish node type
case ElementType of
xeDeclaration: // XML declaration <?xml{declaration}?>
ALine := AIndent + Format('<?xml%s?>', [WriteInnerTag]);
xeStylesheet: // Stylesheet <?xml-stylesheet{stylesheet}?>
ALine := AIndent + Format('<?xml-stylesheet%s?>', [WriteInnerTag]);
xeDoctype:
begin
if NodeCount = 0 then
ALine := AIndent + Format('<!DOCTYPE %s %s>', [Name, ValueDirect])
else begin
ALine := AIndent + Format('<!DOCTYPE %s %s [', [Name, ValueDirect]) + ALineFeed;
WriteStringToStream(S, ALine);
for i := 0 to NodeCount - 1 do begin
Nodes[i].WriteToStream(S);
WriteStringToStream(S, ALineFeed);
end;
ALine := ']>';
end;
end;
xeElement:
ALine := AIndent + Format('<!ELEMENT %s %s>', [Name, ValueDirect]);
xeAttList:
ALine := AIndent + Format('<!ATTLIST %s %s>', [Name, ValueDirect]);
xeEntity:
ALine := AIndent + Format('<!ENTITY %s %s>', [Name, ValueDirect]);
xeNotation:
ALine := AIndent + Format('<!NOTATION %s %s>', [Name, ValueDirect]);
xeComment: // Comment
ALine := AIndent + Format('', [ValueDirect]);
xeCData: // literal data <![CDATA[{data}]]>
ALine := AIndent + Format('<![CDATA[%s]]>', [ValueDirect]);
xeExclam: // Any <!data>
ALine := AIndent + Format('<!%s>', [ValueDirect]);
xeQuestion: // Any <?data?>
ALine := AIndent + Format('<?%s?>', [ValueDirect]);
xeCharData:
ALine := FValue;
xeUnknown: // Any <data>
ALine := AIndent + Format('<%s>', [ValueDirect]);
xeNormal: // normal nodes (xeNormal)
begin
// Write tag
ALine := ALine + Format('<%s%s>', [FName, WriteInnerTag]);
// Write value (if any)
ALine := ALine + FValue;
if (NodeCount > 0) then
// ..and a linefeed
ALine := ALine + ALineFeed;
WriteStringToStream(S, ALine);
// Write child elements
for i := 0 to NodeCount - 1 do begin
ThisNode := Nodes[i];
NextNode := Nodes[i + 1];
ThisNode.WriteToStream(S);
AddLineFeed := True;
if ThisNode.ElementType = xeCharData then
AddLineFeed := False;
if assigned(NextNode) then
if NextNode.ElementType = xeCharData then
AddLineFeed := False;
if AddLineFeed then
WriteStringToStream(S, ALineFeed);
end;
// Write end tag
ALine := '';
if not QualifyAsDirectNode then begin
if NodeCount > 0 then
ALine := AIndent;
ALine := ALine + Format('</%s>', [FName]);
end;
end;
else
raise EFilerError.Create(sxeIllegalElementType);
end;//case
WriteStringToStream(S, ALine);
// Call the onprogress
if assigned(Document) then Document.DoProgress(S.Position);
end;
function TXmlNode.WriteToString: string;
var
S: TsdStringStream;
begin
// We will simply call WriteToStream and collect the result as string using
// a string stream
S := TsdStringStream.Create('');
try
WriteToStream(S);
Result := S.DataString;
finally
S.Free;
end;
end;
procedure TXmlNode.WriteWidestring(const AName: string;
const AValue: widestring; const ADefault: widestring);
begin
WriteString(AName, FromWidestring(AValue), ADefault);
end;
{ TXmlNodeList }
function TXmlNodeList.GetItems(Index: Integer): TXmlNode;
begin
Result := TXmlNode(Get(Index));
end;
procedure TXmlNodeList.SetItems(Index: Integer; const Value: TXmlNode);
begin
Put(Index, TPointer(Value));
end;
{ TNativeXml }
procedure TNativeXml.Assign(Source: TPersistent);
// local
procedure SetDocumentRecursively(ANode: TXmlNode; ADocument: TNativeXml);
var
i: integer;
begin
ANode.Document := ADocument;
for i := 0 to ANode.NodeCount - 1 do
SetDocumentRecursively(ANode.Nodes[i], ADocument);
end;
// main
begin
if Source is TNativeXml then begin
// Copy private members
FBinaryEncoding := TNativeXml(Source).FBinaryEncoding;
FDropCommentsOnParse := TNativeXml(Source).FDropCommentsOnParse;
FExternalEncoding := TNativeXml(Source).FExternalEncoding;
FParserWarnings := TNativeXml(Source).FParserWarnings;
FIndentString := TNativeXml(Source).FIndentString;
FUseFullNodes := TNativeXml(Source).FUseFullNodes;
FUtf8Encoded := TNativeXml(Source).FUtf8Encoded;
FWriteOnDefault := TNativeXml(Source).FWriteOnDefault;
FXmlFormat := TNativeXml(Source).FXmlFormat;
FSortAttributes := TNativeXml(Source).FSortAttributes;
// Assign root
FRootNodes.Assign(TNativeXml(Source).FRootNodes);
// Set Document property recursively
SetDocumentRecursively(FRootNodes, Self);
end else if Source is TXmlNode then begin
// Assign this node to the FRootNodes property
FRootNodes.Assign(Source);
// Set Document property recursively
SetDocumentRecursively(FRootNodes, Self);
end else
inherited;
end;
procedure TNativeXml.Clear;
var
ANode: TXmlNode;
begin
// Reset defaults
SetDefaults;
// Clear root
FRootNodes.Clear;
// Build default items in RootNodes
// - first the declaration
ANode := TXmlNode.CreateType(Self, xeDeclaration);
ANode.Name := 'xml';
ANode.AttributeAdd('version', cDefaultVersionString);
ANode.AttributeAdd('encoding', cDefaultEncodingString);
FRootNodes.NodeAdd(ANode);
// - then the root node
FRootNodes.NodeNew('');
end;
procedure TNativeXml.CopyFrom(Source: TNativeXml);
begin
if not assigned(Source) then exit;
Assign(Source);
end;
constructor TNativeXml.Create;
begin
inherited Create;
FRootNodes := TXmlNode.Create(Self);
Clear;
end;
constructor TNativeXml.CreateName(const ARootName: string);
begin
Create;
Root.Name := ARootName;
end;
destructor TNativeXml.Destroy;
begin
FreeAndNil(FRootNodes);
inherited;
end;
procedure TNativeXml.DoNodeLoaded(Node: TXmlNode);
begin
if assigned(FOnNodeLoaded) then
FOnNodeLoaded(Self, Node);
end;
procedure TNativeXml.DoNodeNew(Node: TXmlNode);
begin
if assigned(FOnNodeNew) then
FOnNodeNew(Self, Node);
end;
procedure TNativeXml.DoProgress(Size: integer);
begin
if assigned(FOnProgress) then FOnProgress(Self, Size);
end;
procedure TNativeXml.DoUnicodeLoss(Sender: TObject);
begin
if assigned(FOnUnicodeLoss) then FOnUnicodeLoss(Self);
end;
function TNativeXml.GetCommentString: string;
// Get the first comment node, and return its value
var
ANode: TXmlNode;
begin
Result := '';
ANode := FRootNodes.NodeByElementType(xeComment);
if assigned(ANode) then
Result := ANode.ValueAsString;
end;
function TNativeXml.GetEncodingString: string;
begin
Result := '';
if FRootNodes.NodeCount > 0 then
if FRootNodes[0].ElementType = xeDeclaration then
Result := FRootNodes[0].AttributeByName['encoding'];
end;
function TNativeXml.GetEntityByName(AName: string): string;
var
i, j: integer;
begin
Result := '';
for i := 0 to FRootNodes.NodeCount - 1 do
if FRootNodes[i].ElementType = xeDoctype then with FRootNodes[i] do begin
for j := 0 to NodeCount - 1 do
if (Nodes[j].ElementType = xeEntity) and (Nodes[j].Name = AName) then begin
Result := UnQuoteString(Trim(Nodes[j].ValueDirect));
exit;
end;
end;
end;
function TNativeXml.GetRoot: TXmlNode;
begin
Result := FRootNodes.NodeByElementType(xeNormal);
end;
function TNativeXml.GetStyleSheetNode: TXmlNode;
begin
Result := FRootNodes.NodeByElementType(xeStylesheet);
if not assigned(Result) then begin
// Add a stylesheet node as second one if none present
Result := TXmlNode.CreateType(Self, xeStyleSheet);
FRootNodes.NodeInsert(1, Result);
end;
end;
function TNativeXml.GetVersionString: string;
begin
Result := '';
if FRootNodes.NodeCount > 0 then
if FRootNodes[0].ElementType = xeDeclaration then
Result := FRootNodes[0].AttributeByName['version'];
end;
function TNativeXml.IsEmpty: boolean;
var
ARoot: TXmlNode;
begin
Result := True;
ARoot := GetRoot;
if assigned(ARoot) then Result := ARoot.IsClear;
end;
function TNativeXml.LineFeed: string;
begin
case XmlFormat of
xfReadable: Result := #13#10;
xfCompact: Result := #10;
else
Result := #10;
end;
end;
procedure TNativeXml.LoadFromFile(const FileName: string);
var
S: TStream;
begin
S := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
LoadFromStream(S);
finally
S.Free;
end;
end;
procedure TNativeXml.LoadFromStream(Stream: TStream);
var
B: TsdBufferedReadStream;
begin
// Create buffer filter. Since we read from the original stream a buffer at a
// time, this speeds up the reading process for disk-based files.
B := TsdBufferedReadStream.Create(Stream, False);
try
// We will create a conversion stream as intermediate
if Utf8Encoded then
FCodecStream := TsdUtf8Stream.Create(B)
else
FCodecStream := TsdAnsiStream.Create(B);
try
// Connect events
FCodecStream.OnUnicodeLoss := DoUnicodeLoss;
// Read from stream
ReadFromStream(FCodecStream);
// Set our external encoding
FExternalEncoding := FCodecStream.Encoding;
// Set internal encoding
if (ExternalEncoding = seUtf8) or (EncodingString = 'UTF-8') then
FUtf8Encoded := True;
finally
FreeAndNil(FCodecStream);
end;
finally
B.Free;
end;
end;
procedure TNativeXml.ParseDTD(ANode: TXmlNode; S: TStream);
// DTD parsing is quite different from normal node parsing so it is brought
// under in the main NativeXml object
procedure ParseMarkupDeclarations;
var
Ch: char;
begin
repeat
ANode.NodeNew('').ReadFromStream(S);
// Read character, exit if none available
repeat
if S.Read(Ch, 1) = 0 then exit;
// Read until end markup declaration or end
until not (Ch in cControlChars);
if Ch = ']' then break;
S.Seek(-1, soCurrent);
until False;
end;
// main
var
Prework: string;
Ch: char;
Words: TStringList;
begin
// Get the name and external ID
Prework := '';
repeat
// Read character, exit if none available
if S.Read(Ch, 1) = 0 then exit;
// Read until markup declaration or end
if Ch in ['[', '>'] then break;
Prework := Prework + Ch;
until False;
Words := TStringList.Create;
try
ParseAttributes(Prework, 1, length(Prework) + 1, Words);
// First word is name
if Words.Count > 0 then begin
ANode.Name := Words[0];
Words.Delete(0);
// Put the rest in the valuedirect
ANode.ValueDirect := Trim(StringReplace(Words.Text, #13#10, ' ', [rfReplaceAll]));
end;
finally
Words.Free;
end;
if Ch = '[' then begin
// Parse any !ENTITY nodes and such
ParseMarkupDeclarations;
// read final tag
repeat
if S.Read(Ch, 1) = 0 then exit;
if Ch = '>' then break;
until False;
end;
end;
procedure TNativeXml.ReadFromStream(S: TStream);
var
i: integer;
ANode: TXmlNode;
AEncoding: string;
NormalCount, DeclarationCount,
DoctypeCount, CDataCount: integer;
NormalPos, DoctypePos: integer;
begin
FAbortParsing := False;
with FRootNodes do begin
// Clear the old root nodes - we do not reset the defaults
Clear;
DoProgress(0);
repeat
ANode := NodeNew('');
ANode.ReadFromStream(S);
if AbortParsing then exit;
// XML declaration
if ANode.ElementType = xeDeclaration then begin
if ANode.HasAttribute('encoding') then
AEncoding := ANode.AttributeByName['encoding'];
// Check encoding
if assigned(FCodecStream) and (AEncoding = 'UTF-8') then
FCodecStream.Encoding := seUTF8;
end;
// Skip clear nodes
if ANode.IsClear then
NodeDelete(NodeCount - 1);
until S.Position >= S.Size;
DoProgress(S.Size);
// Do some checks
NormalCount := 0;
DeclarationCount := 0;
DoctypeCount := 0;
CDataCount := 0;
NormalPos := -1;
DoctypePos := -1;
for i := 0 to NodeCount - 1 do begin
// Count normal elements - there may be only one
case Nodes[i].ElementType of
xeNormal:
begin
inc(NormalCount);
NormalPos := i;
end;
xeDeclaration: inc(DeclarationCount);
xeDoctype:
begin
inc(DoctypeCount);
DoctypePos := i;
end;
xeCData: inc(CDataCount);
end;//case
end;
// We *must* have a root node
if NormalCount = 0 then
raise EFilerError.Create(sxeNoRootElement);
// Do some validation if we allow parser warnings
if FParserWarnings then begin
// Check for more than one root node
if NormalCount > 1 then raise EFilerError.Create(sxeMoreThanOneRootElement);
// Check for more than one xml declaration
if DeclarationCount > 1 then raise EFilerError.Create(sxeMoreThanOneDeclaration);
// Declaration must be first element if present
if DeclarationCount = 1 then
if Nodes[0].ElementType <> xeDeclaration then
raise EFilerError.Create(sxeDeclarationMustBeFirstElem);
// Check for more than one DTD
if DoctypeCount > 1 then raise EFilerError.Create(sxeMoreThanOneDoctype);
// Check if DTD is after root, this is not allowed
if (DoctypeCount = 1) and (DoctypePos > NormalPos) then
raise EFilerError.Create(sxeDoctypeAfterRootElement);
// No CDATA in root allowed
if CDataCount > 0 then
raise EFilerError.Create(sxeCDataInRoot);
end;
end;//with
end;
procedure TNativeXml.ReadFromString(const AValue: string);
var
S: TStream;
begin
S := TsdStringStream.Create(AValue);
try
ReadFromStream(S);
finally
S.Free;
end;
end;
procedure TNativeXml.ResolveEntityReferences;
begin
if assigned(Root) then
Root.ResolveEntityReferences;
end;
procedure TNativeXml.SaveToFile(const FileName: string);
var
S: TStream;
begin
S := TFileStream.Create(FileName, fmCreate);
try
SaveToStream(S);
finally
S.Free;
end;
end;
procedure TNativeXml.SaveToStream(Stream: TStream);
var
B: TsdBufferedWriteStream;
begin
// Create buffer filter. Since we write a buffer at a time to the destination
// stream, this speeds up the writing process for disk-based files.
B := TsdBufferedWriteStream.Create(Stream, False);
try
// Create conversion stream
if Utf8Encoded then
FCodecStream := TsdUtf8Stream.Create(B)
else
FCodecStream := TsdAnsiStream.Create(B);
try
// Set External encoding
FCodecStream.Encoding := FExternalEncoding;
WriteToStream(FCodecStream);
finally
FreeAndNil(FCodecStream);
end;
finally
B.Free;
end;
end;
procedure TNativeXml.SetCommentString(const Value: string);
// Find first comment node and set it's value, otherwise add new comment node
// right below the xml declaration
var
ANode: TXmlNode;
begin
ANode := FRootNodes.NodeByElementType(xeComment);
if not assigned(ANode) and (length(Value) > 0) then begin
ANode := TXmlNode.CreateType(Self, xeComment);
FRootNodes.NodeInsert(1, ANode);
end;
if assigned(ANode) then ANode.ValueAsString := Value;
end;
procedure TNativeXml.SetDefaults;
begin
// Defaults
FExternalEncoding := cDefaultExternalEncoding;
FXmlFormat := cDefaultXmlFormat;
FWriteOnDefault := cDefaultWriteOnDefault;
FBinaryEncoding := cDefaultBinaryEncoding;
FUtf8Encoded := cDefaultUtf8Encoded;
FIndentString := cDefaultIndentString;
FDropCommentsOnParse := cDefaultDropCommentsOnParse;
FUseFullNodes := cDefaultUseFullNodes;
FSortAttributes := cDefaultSortAttributes;
FFloatAllowScientific := cDefaultFloatAllowScientific;
FFloatSignificantDigits := cDefaultFloatSignificantDigits;
end;
procedure TNativeXml.SetEncodingString(const Value: string);
var
ANode: TXmlNode;
begin
if Value = GetEncodingString then exit;
ANode := FRootNodes[0];
if not assigned(ANode) or (ANode.ElementType <> xeDeclaration) then begin
if length(Value) > 0 then begin
ANode := TXmlNode.CreateType(Self, xeDeclaration);
FRootNodes.NodeInsert(0, ANode);
end;
end;
if assigned(ANode) then
ANode.AttributeByName['encoding'] := Value;
end;
procedure TNativeXml.SetVersionString(const Value: string);
var
ANode: TXmlNode;
begin
if Value = GetVersionString then exit;
ANode := FRootNodes[0];
if not assigned(ANode) or (ANode.ElementType <> xeDeclaration) then begin
if length(Value) > 0 then begin
ANode := TXmlNode.CreateType(Self, xeDeclaration);
FRootNodes.NodeInsert(0, ANode);
end;
end;
if assigned(ANode) then
ANode.AttributeByName['version'] := Value;
end;
procedure TNativeXml.WriteToStream(S: TStream);
var
i: integer;
begin
if not assigned(Root) and FParserWarnings then
raise EFilerError.Create(sxeRootElementNotDefined);
DoProgress(0);
// write the root nodes
for i := 0 to FRootNodes.NodeCount - 1 do begin
FRootNodes[i].WriteToStream(S);
WriteStringToStream(S, LineFeed);
end;
DoProgress(S.Size);
end;
function TNativeXml.WriteToString: string;
var
S: TsdStringStream;
begin
S := TsdStringStream.Create('');
try
WriteToStream(S);
Result := S.DataString;
finally
S.Free;
end;
end;
{ TsdCodecStream }
constructor TsdCodecStream.Create(AStream: TStream);
begin
inherited Create;
FStream := AStream;
end;
function TsdCodecStream.InternalRead(var Buffer{$IFDEF CLR}: array of Byte{$ENDIF}; Offset, Count: Longint): Longint;
// Read from FStream and pass back data
var
i, j: integer;
BOM: array[0..3] of byte;
BytesRead: integer;
Found: boolean;
begin
Result := 0;
if FMode = umUnknown then begin
FMode := umRead;
// Check FStream
if not assigned(FStream) then
raise EStreamError.Create(sxeCodecStreamNotAssigned);
// Determine encoding
FEncoding := se8Bit;
BytesRead := FStream.Read(BOM, 4);
for i := 0 to cBomInfoCount - 1 do begin
Found := True;
for j := 0 to Min(BytesRead, cBomInfo[i].Len) - 1 do begin
if BOM[j] <> cBomInfo[i].BOM[j] then begin
Found := False;
break;
end;
end;
if Found then break;
end;
if Found then begin
FEncoding := cBomInfo[i].Enc;
FWriteBom := cBomInfo[i].HasBOM;
end else begin
// Unknown.. default to this
FEncoding := se8Bit;
FWriteBom := False;
end;
// Some encodings are not supported (yet)
if FEncoding in [seUCS4BE, seUCS4_2143, seUCS4_3412, seEBCDIC] then
raise EStreamError.Create(sxeUnsupportedEncoding);
// Correct stream to start position
if FWriteBom then
FStream.Seek(cBomInfo[i].Len - BytesRead, soCurrent)
else
FStream.Seek(-BytesRead, soCurrent);
// Check if we must swap byte order
if FEncoding in [se16BitBE, seUTF16BE] then
FSwapByteOrder := True;
end;
// Check mode
if FMode <> umRead then
raise EStreamError.Create(sxeCannotReadCodecForWriting);
// Check count
if Count <> 1 then
raise EStreamError.Create(sxeCannotReadMultipeChar);
// Now finally read
TBytes(Buffer)[Offset] := ReadByte;
if TBytes(Buffer)[Offset] <> 0 then Result := 1;
end;
{$IFDEF CLR}
function TsdCodecStream.Read(var Buffer: array of Byte; Offset, Count: Longint): Longint;
begin
Result := InternalRead(Buffer, Offset, Count);
end;
{$ELSE}
function TsdCodecStream.Read(var Buffer; Count: Longint): Longint;
begin
Result := InternalRead(Buffer, 0, Count);
end;
{$ENDIF}
function TsdCodecStream.ReadByte: byte;
begin
// default does nothing
Result := 0;
end;
function TsdCodecStream.InternalSeek(Offset: Longint; Origin: TSeekOrigin): Longint;
begin
Result := 0;
if FMode = umUnknown then
raise EStreamError.Create(sxeCannotSeekBeforeReadWrite);
if Origin = soCurrent then begin
if Offset = 0 then begin
// Position
Result := FStream.Position;
exit;
end;
if (FMode = umRead) and ((Offset = -1) or (Offset = -2)) then begin
FBuffer := '';
case Offset of
-1: FStream.Seek(FPosMin1, soBeginning);
-2: FStream.Seek(FPosMin2, soBeginning);
end;
exit;
end;
end;
if (Origin = soEnd) and (Offset = 0) then begin
// Size
Result := FStream.Size;
exit;
end;
// Ignore set position from beginning (used in Size command)
if Origin = soBeginning then exit;
// Arriving here means we cannot do it
raise EStreamError.Create(sxeCannotPerformSeek);
end;
{$IFDEF CLR}
function TsdCodecStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
Result := InternalSeek(Offset, Origin);
end;
{$ELSE}
function TsdCodecStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
Result := InternalSeek(Offset, TSeekOrigin(Origin));
end;
{$ENDIF}
procedure TsdCodecStream.StorePrevPositions;
begin
FPosMin2 := FPosMin1;
FPosMin1 := FStream.Position;
end;
function TsdCodecStream.InternalWrite(const Buffer{$IFDEF CLR}: array of Byte{$ENDIF}; Offset, Count: Longint): Longint;
var
i: integer;
begin
if FMode = umUnknown then begin
FMode := umWrite;
// Some encodings are not supported (yet)
if FEncoding in [seUCS4BE, seUCS4_2143, seUCS4_3412, seEBCDIC] then
raise EStreamError.Create(sxeUnsupportedEncoding);
// Find correct encoding info
for i := 0 to cBomInfoCount - 1 do
if cBomInfo[i].Enc = FEncoding then begin
FWriteBom := cBomInfo[i].HasBOM;
break;
end;
// Write BOM
if FWriteBom then
FStream.WriteBuffer(cBomInfo[i].BOM, cBomInfo[i].Len);
// Check if we must swap byte order
if FEncoding in [se16BitBE, seUTF16BE] then
FSwapByteOrder := True;
end;
if FMode <> umWrite then
raise EStreamError.Create(sxeCannotWriteCodecForReading);
WriteBuf(Buffer, Offset, Count);
Result := Count;
end;
{$IFDEF CLR}
function TsdCodecStream.Write(const Buffer: array of Byte; Offset, Count: Longint): Longint;
begin
Result := InternalWrite(Buffer, Offset, Count);
end;
{$ELSE}
function TsdCodecStream.Write(const Buffer; Count: Longint): Longint;
begin
Result := InternalWrite(Byte(Buffer), 0, Count);
end;
{$ENDIF}
procedure TsdCodecStream.WriteBuf(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Offset, Count: longint);
var
i: integer;
begin
// Default just writes out bytes one by one. We override this in descendants
// to provide faster writes for some modes
for i := 0 to Count - 1 do
{$IFDEF CLR}
WriteByte(Buffer[Offset + i]);
{$ELSE}
WriteByte(TBytes(Buffer)[Offset + i]);
{$ENDIF}
end;
procedure TsdCodecStream.WriteByte(const B: byte);
begin
// default does nothing
end;
{$IFDEF CLR}
procedure TsdCodecStream.SetSize(NewSize: Int64);
begin
// default does nothing
end;
{$ENDIF}
{ TsdAnsiStream }
function TsdAnsiStream.ReadByte: byte;
var
B: byte;
W: word;
begin
StorePrevPositions;
case FEncoding of
se8Bit, seUTF8:
begin
// Just a flat read of one byte. UTF8 is not converted back, when UTF8
// encoding is detected, the document will set Utf8Encoded to True.
B := 0;
FStream.Read(B, 1);
Result := B;
end;
se16BitBE,se16BitLE,seUTF16BE,seUTF16LE:
begin
// Read two bytes
W := 0;
FStream.Read(W, 2);
// Swap byte order
if FSwapByteOrder then
W := swap(W);
// Unicode warning loss
if ((W and $FF00) > 0) and not FWarningUnicodeLoss then begin
FWarningUnicodeLoss := True;
if assigned(FOnUnicodeLoss) then
FOnUnicodeLoss(Self);
// We cannot display unicode range characters
Result := ord('?');
end else
Result := W and $FF;
end;
else
raise EStreamError.Create(sxeUnsupportedEncoding);
end;
end;
procedure TsdAnsiStream.WriteBuf(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Offset, Count: longint);
begin
case FEncoding of
se8Bit:
begin
// one on one
if StreamWrite(FStream, Buffer, Offset, Count) <> Count then
raise EStreamError.Create(sxeCannotWriteToOutputStream);
end;
else
inherited;
end;
end;
procedure TsdAnsiStream.WriteByte(const B: byte);
var
SA, SU: string;
W: word;
begin
case FEncoding of
se8Bit:
begin
// Just a flat write of one byte
FStream.Write(B, 1);
end;
seUTF8:
begin
// Convert Ansi to UTF8
SA := char(B);
SU := sdAnsiToUTF8(SA);
// write out
if FStream.Write(SU[1], length(SU)) = 0 then
raise EStreamError.Create(sxeCannotWriteToOutputStream);
end;
se16BitBE,se16BitLE,seUTF16BE,seUTF16LE:
begin
// Convert Ansi to Unicode
W := B;
// Swap byte order
if FSwapByteOrder then
W := swap(W);
// write out
if FStream.Write(W, 2) = 0 then
raise EStreamError.Create(sxeCannotWriteToOutputStream);
end;
else
raise EStreamError.Create(sxeUnsupportedEncoding);
end;
end;
{ TsdUtf8Stream }
function TsdUtf8Stream.ReadByte: byte;
var
B, B1, B2, B3: byte;
W: word;
SA: string;
begin
Result := 0;
// New character?
if (Length(FBuffer) = 0) or (FBufferPos > length(FBuffer)) then begin
StorePrevPositions;
FBufferPos := 1;
// Read another char and put in buffer
case FEncoding of
se8Bit:
begin
// read one byte
B := 0;
FStream.Read(B, 1);
SA := char(B);
// Convert to UTF8
FBuffer := sdAnsiToUtf8(SA);
end;
seUTF8:
begin
// Read one, two or three bytes in the buffer
B1 := 0;
FStream.Read(B1, 1);
FBuffer := char(B1);
if (B1 and $80) > 0 then begin
if (B1 and $20) <> 0 then begin
B2 := 0;
FStream.Read(B2, 1);
FBuffer := FBuffer + char(B2);
end;
B3 := 0;
FStream.Read(B3, 1);
FBuffer := FBuffer + char(B3);
end;
end;
se16BitBE,se16BitLE,seUTF16BE,seUTF16LE:
begin
// Read two bytes
W := 0;
FStream.Read(W, 2);
// Swap byte order
if FSwapByteOrder then
W := swap(W);
// Convert to UTF8 in buffer
{$IFDEF D5UP}
FBuffer := sdUnicodeToUtf8(widechar(W));
{$ELSE}
FBuffer := sdUnicodeToUtf8(char(W and $FF));
{$ENDIF}
end;
else
raise EStreamError.Create(sxeUnsupportedEncoding);
end;
end;
// Now we have the buffer, so read
if (FBufferPos > 0) and (FBufferPos <= length(FBuffer)) then
Result := byte(FBuffer[FBufferPos]);
inc(FBufferPos);
end;
procedure TsdUtf8Stream.WriteBuf(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Offset, Count: longint);
begin
case FEncoding of
seUtf8:
begin
// one on one
if StreamWrite(FStream, Buffer, Offset, Count) <> Count then
raise EStreamError.Create(sxeCannotWriteToOutputStream);
end
else
inherited;
end;
end;
procedure TsdUtf8Stream.WriteByte(const B: byte);
var
SA: string;
SW: widestring;
MustWrite: boolean;
begin
case FEncoding of
se8Bit,se16BitBE,se16BitLE,seUTF16BE,seUTF16LE:
begin
MustWrite := True;
case Length(FBuffer) of
0:
begin
FBuffer := char(B);
if (B and $80) <> 0 then MustWrite := False;
end;
1:
begin
FBuffer := FBuffer + char(B);
if (byte(FBuffer[1]) and $20) <> 0 then MustWrite := False;
end;
2: FBuffer := FBuffer + char(B);
end;
if MustWrite then begin
if FEncoding = se8Bit then begin
// Convert to ansi
SA := sdUtf8ToAnsi(FBuffer);
// write out
if length(SA) = 1 then
if FStream.Write(SA[1], 1) <> 1 then
raise EStreamError.Create(sxeCannotWriteToOutputStream);
end else begin
// Convert to unicode
SW := sdUtf8ToUnicode(FBuffer);
// write out
if length(SW) = 1 then
if FStream.Write(SW[1], 2) <> 2 then
raise EStreamError.Create(sxeCannotWriteToOutputStream);
end;
FBuffer := '';
end;
end;
seUTF8:
begin
// Just a flat write of one byte
if FStream.Write(B, 1) <> 1 then
raise EStreamError.Create(sxeCannotWriteToOutputStream);
end;
else
raise EStreamError.Create(sxeUnsupportedEncoding);
end;
end;
{$IFDEF CLR}
{ TsdBufferedStream }
constructor TsdBufferedStream.Create(AStream: TStream; Owned: Boolean = False);
begin
inherited Create;
FStream := AStream;
FOwned := Owned;
end;
destructor TsdBufferedStream.Destroy;
begin
if FOwned then FreeAndNil(FStream);
inherited Destroy;
end;
function TsdBufferedStream.Read(var Buffer: array of Byte; Offset, Count: Longint): Longint;
begin
Result := FStream.Read(Buffer, Offset, Count);
end;
function TsdBufferedStream.Write(const Buffer: array of Byte; Offset, Count: Longint): Longint;
begin
Result := FStream.Write(Buffer, Offset, Count);
end;
function TsdBufferedStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
Result := FStream.Seek(Offset, Origin);
end;
procedure TsdBufferedStream.SetSize(NewSize: Int64);
begin
FStream.Size := NewSize;
end;
{$ELSE}
{ TsdBufferedReadStream }
const
cMaxBufferSize = $10000; // 65536 bytes in the buffer
procedure TsdBufferedReadStream.CheckPosition;
var
NewPage: integer;
FStartPos: longint;
begin
// Page and buffer position
NewPage := FPosition div cMaxBufferSize;
FBufPos := FPosition mod cMaxBufferSize;
// Read new page if required
if (NewPage <> FPage) then begin
// New page and buffer
FPage := NewPage;
// Start position in stream
FStartPos := FPage * cMaxBufferSize;
FBufSize := Min(cMaxBufferSize, FStream.Size - FStartPos);
FStream.Seek(FStartPos, soBeginning);
if FBufSize > 0 then
FStream.Read(FBuffer^, FBufSize);
end;
FMustCheck := False;
end;
constructor TsdBufferedReadStream.Create(AStream: TStream; Owned: boolean);
begin
inherited Create;
FStream := AStream;
FOwned := Owned;
FMustCheck := True;
FPage := -1; // Set to invalid number to force an update on first read
ReallocMem(FBuffer, cMaxBufferSize);
end;
destructor TsdBufferedReadStream.Destroy;
begin
if FOwned then FreeAndNil(FStream);
ReallocMem(FBuffer, 0);
inherited;
end;
function TsdBufferedReadStream.Read(var Buffer; Count: longint): Longint;
var
Packet: PByte;
PacketCount: integer;
begin
// Set the right page
if FMustCheck then CheckPosition;
// Special case - read one byte, most often
if (Count = 1) and (FBufPos < FBufSize - 1) then begin
byte(Buffer) := FBuffer^[FBufPos];
inc(FBufPos);
inc(FPosition);
Result := 1;
exit;
end;
// general case
Packet := @Buffer;
Result := 0;
while Count > 0 do begin
PacketCount := min(FBufSize - FBufPos, Count);
if PacketCount <= 0 then exit;
Move(FBuffer^[FBufPos], Packet^, PacketCount);
dec(Count, PacketCount);
inc(Packet, PacketCount);
inc(Result, PacketCount);
inc(FPosition, PacketCount);
inc(FBufPos, PacketCount);
if FBufPos >= FBufSize then CheckPosition;
end;
end;
function TsdBufferedReadStream.Seek(Offset: longint; Origin: Word): Longint;
begin
case Origin of
soFromBeginning:
FPosition := Offset;
soFromCurrent:
begin
// no need to check in this case - it is the GetPosition command
if Offset = 0 then begin
Result := FPosition;
exit;
end;
FPosition := FPosition + Offset;
end;
soFromEnd:
FPosition := FStream.Size + Offset;
end;//case
Result := FPosition;
FMustCheck := True;
end;
function TsdBufferedReadStream.Write(const Buffer; Count: longint): Longint;
begin
raise EStreamError.Create(sxeCannotWriteCodecForReading);
end;
{ TsdBufferedWriteStream }
constructor TsdBufferedWriteStream.Create(AStream: TStream;
Owned: boolean);
begin
inherited Create;
FStream := AStream;
FOwned := Owned;
ReallocMem(FBuffer, cMaxBufferSize);
end;
destructor TsdBufferedWriteStream.Destroy;
begin
Flush;
if FOwned then FreeAndNil(FStream);
ReallocMem(FBuffer, 0);
inherited;
end;
procedure TsdBufferedWriteStream.Flush;
begin
// Write the buffer to the stream
if FBufPos > 0 then begin
FStream.Write(FBuffer^, FBufPos);
FBufPos := 0;
end;
end;
function TsdBufferedWriteStream.Read(var Buffer; Count: longint): Longint;
begin
raise EStreamError.Create(sxeCannotReadCodecForWriting);
end;
function TsdBufferedWriteStream.Seek(Offset: longint; Origin: Word): Longint;
begin
case Origin of
soFromBeginning:
if Offset = FPosition then begin
Result := FPosition;
exit;
end;
soFromCurrent:
begin
// GetPosition command
if Offset = 0 then begin
Result := FPosition;
exit;
end;
end;
soFromEnd:
if Offset = 0 then begin
Result := FPosition;
exit;
end;
end;//case
raise EStreamError.Create(sxeCannotPerformSeek);
end;
function TsdBufferedWriteStream.Write(const Buffer; Count: longint): Longint;
var
Packet: PByte;
PacketCount: integer;
begin
// Special case - read less bytes than would fill buffersize
if (FBufPos + Count < cMaxBufferSize) then begin
Move(Buffer, FBuffer^[FBufPos], Count);
inc(FBufPos, Count);
inc(FPosition, Count);
Result := Count;
exit;
end;
// general case that wraps buffer
Packet := @Buffer;
Result := 0;
while Count > 0 do begin
PacketCount := min(cMaxBufferSize - FBufPos, Count);
if PacketCount <= 0 then exit;
Move(Packet^, FBuffer^[FBufPos], PacketCount);
dec(Count, PacketCount);
inc(Result, PacketCount);
inc(FPosition, PacketCount);
inc(Packet, PacketCount);
inc(FBufPos, PacketCount);
if FBufPos = cMaxBufferSize then Flush;
end;
end;
{$ENDIF}
{ TsdSurplusReader }
constructor TsdSurplusReader.Create(AStream: TStream);
begin
inherited Create;
FStream := AStream;
end;
function TsdSurplusReader.ReadChar(var Ch: char): integer;
begin
if length(FSurplus) > 0 then begin
Ch := FSurplus[1];
FSurplus := copy(FSurplus, 2, length(FSurplus) - 1);
Result := 1;
end else
Result := FStream.Read(Ch, 1);
end;
function TsdSurplusReader.ReadCharSkipBlanks(var Ch: char): boolean;
begin
Result := False;
repeat
// Read character, exit if none available
if ReadChar(Ch) = 0 then exit;
// Skip if in controlchars
if not (Ch in cControlchars) then break;
until False;
Result := True;
end;
{ TsdStringBuilder }
procedure TsdStringBuilder.AddChar(Ch: Char);
begin
inc(FCurrentIdx);
Reallocate(FCurrentIdx);
FData[FCurrentIdx] := Ch;
end;
procedure TsdStringBuilder.AddString(var S: string);
var
{$IFDEF CLR}
i: integer;
{$ENDIF}
Count: integer;
begin
{$IFDEF CLR}
Count := S.Length;
{$ELSE}
Count := System.length(S);
{$ENDIF}
if Count = 0 then exit;
Reallocate(FCurrentIdx + Count);
{$IFDEF CLR}
for i := 1 to S.Length do
FData[FCurrentIdx + i] := S[i];
{$ELSE}
Move(S[1], FData[FCurrentIdx + 1], Count);
{$ENDIF}
inc(FCurrentIdx, Count);
end;
procedure TsdStringBuilder.Clear;
begin
FCurrentIdx := 0;
end;
function TsdStringBuilder.StringCopy(AFirst, ALength: integer): string;
begin
if ALength > FCurrentIdx - AFirst + 1 then
ALength := FCurrentIdx - AFirst + 1;
Result := Copy(FData, AFirst, ALength);
end;
constructor TsdStringBuilder.Create;
begin
inherited Create;
SetLength(FData, 64);
end;
function TsdStringBuilder.GetData(Index: integer): Char;
begin
Result := FData[Index];
end;
procedure TsdStringBuilder.Reallocate(RequiredLength: integer);
begin
{$IFDEF CLR}
while FData.Length < RequiredLength do
SetLength(FData, FData.Length * 2);
{$ELSE}
while System.Length(FData) < RequiredLength do
SetLength(FData, System.Length(FData) * 2);
{$ENDIF}
end;
function TsdStringBuilder.Value: string;
begin
Result := Copy(FData, 1, FCurrentIdx);
end;
initialization
{$IFDEF TRIALXML}
ShowMessage(
'This is the unregistered version of NativeXml.pas'#13#13 +
'Please visit http://www.simdesign.nl/xml.html to buy the'#13 +
'registered version for Eur 29.95 (source included).');
{$ENDIF}
end.