paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-07 22:58:14 +02:00
Code Issues Packages Projects Releases Wiki Activity

lazutils: removed old xml implementation, interface alias to new

Browse Source 
git-svn-id: trunk@37761 -
This commit is contained in:
mattias 2012-06-24 15:46:28 +00:00
parent 8b57f2995c
commit 45419f6cc9
7 changed files with 157 additions and 4631 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
components/codetools/examples/TestNewXMLCfg.lpr
View File

@ -103,16 +103,13 @@ procedure TMyApplication.Test1;
var
Filename: String;
begin
// write with old
Filename:='test1.xml';
Test(Filename,true,true);
Test(Filename,true,true); // write with old
Test(Filename,true,false); // read old with old
Test(Filename,false,false); // read old with new
// write with new
Filename:='test2.xml';
Test(Filename,false,true);
Test(Filename,false,true); // write with new
Test(Filename,false,false); // read new with new
Test(Filename,true,false); // read new with old
end;

94
components/lazutils/laz2_xmlread.pas
View File

@ -30,7 +30,7 @@ unit laz2_XMLRead;
interface
uses
SysUtils, Classes, laz2_DOM;
SysUtils, Classes, laz2_DOM, lazutf8classes;
type
TErrorSeverity = (esWarning, esError, esFatal);
@ -60,18 +60,21 @@ type
procedure ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String; Flags: TXMLReaderFlags = []); overload;
procedure ReadXMLFile(out ADoc: TXMLDocument; var f: Text; Flags: TXMLReaderFlags = []); overload;
procedure ReadXMLFile(out ADoc: TXMLDocument; var f: File; Flags: TXMLReaderFlags = []); overload;
procedure ReadXMLFile(out ADoc: TXMLDocument; f: TStream; Flags: TXMLReaderFlags = []); overload;
procedure ReadXMLFile(out ADoc: TXMLDocument; f: TStream; const ABaseURI: String; Flags: TXMLReaderFlags = []); overload;
procedure ReadXMLFragment(AParentNode: TDOMNode; const AFilename: String; Flags: TXMLReaderFlags = []); overload;
procedure ReadXMLFragment(AParentNode: TDOMNode; var f: Text; Flags: TXMLReaderFlags = []); overload;
procedure ReadXMLFragment(AParentNode: TDOMNode; var f: TStream; Flags: TXMLReaderFlags = []); overload;
procedure ReadXMLFragment(AParentNode: TDOMNode; var f: TStream; const ABaseURI: String; Flags: TXMLReaderFlags = []); overload;
procedure ReadXMLFragment(AParentNode: TDOMNode; var f: File; Flags: TXMLReaderFlags = []); overload;
procedure ReadXMLFragment(AParentNode: TDOMNode; f: TStream; Flags: TXMLReaderFlags = []); overload;
procedure ReadXMLFragment(AParentNode: TDOMNode; f: TStream; const ABaseURI: String; Flags: TXMLReaderFlags = []); overload;
procedure ReadDTDFile(out ADoc: TXMLDocument; const AFilename: String); overload;
procedure ReadDTDFile(out ADoc: TXMLDocument; var f: Text); overload;
procedure ReadDTDFile(out ADoc: TXMLDocument; var f: TStream); overload;
procedure ReadDTDFile(out ADoc: TXMLDocument; var f: TStream; const ABaseURI: String); overload;
procedure ReadDTDFile(out ADoc: TXMLDocument; var f: File); overload;
procedure ReadDTDFile(out ADoc: TXMLDocument; f: TStream); overload;
procedure ReadDTDFile(out ADoc: TXMLDocument; f: TStream; const ABaseURI: String); overload;
type
TDOMParseOptions = class(TObject)
@ -4136,6 +4139,29 @@ begin
end;
end;
procedure ReadXMLFile(out ADoc: TXMLDocument; var f: File;
Flags: TXMLReaderFlags);
var
BufSize: Int64;
ms: TMemoryStream;
begin
ADoc := nil;
BufSize := FileSize(f) + 1;
if BufSize <= 1 then
exit;
ms:=TMemoryStream.Create;
try
ms.Size:=BufSize;
BlockRead(f, ms.Memory^, BufSize - 1);
PChar(ms.Memory)[BufSize - 1] := #0;
ms.Position:=0;
ReadXMLFile(ADoc,ms,Flags);
finally
ms.Free;
end;
end;
procedure ReadXMLFile(out ADoc: TXMLDocument; f: TStream; Flags: TXMLReaderFlags);
begin
ReadXMLFile(ADoc, f, 'stream:', Flags);
@ -4147,7 +4173,7 @@ var
FileStream: TStream;
begin
ADoc := nil;
FileStream := TFileStream.Create(UTF8ToSys(AFilename), fmOpenRead+fmShareDenyWrite);
FileStream := TFileStreamUTF8.Create(AFilename, fmOpenRead+fmShareDenyWrite);
try
ReadXMLFile(ADoc, FileStream, FilenameToURI(AFilename), Flags);
finally
@ -4171,7 +4197,7 @@ begin
end;
end;
procedure ReadXMLFragment(AParentNode: TDOMNode; var f: TStream;
procedure ReadXMLFragment(AParentNode: TDOMNode; f: TStream;
const ABaseURI: String; Flags: TXMLReaderFlags);
var
Reader: TXMLReader;
@ -4188,7 +4214,29 @@ begin
end;
end;
procedure ReadXMLFragment(AParentNode: TDOMNode; var f: TStream;
procedure ReadXMLFragment(AParentNode: TDOMNode; var f: File;
Flags: TXMLReaderFlags);
var
BufSize: Int64;
ms: TMemoryStream;
begin
BufSize := FileSize(f) + 1;
if BufSize <= 1 then
exit;
ms:=TMemoryStream.Create;
try
ms.Size:=BufSize;
BlockRead(f, ms.Memory^, BufSize - 1);
PChar(ms.Memory)[BufSize - 1] := #0;
ms.Position:=0;
ReadXMLFragment(AParentNode,ms,'stream:',Flags);
finally
ms.Free;
end;
end;
procedure ReadXMLFragment(AParentNode: TDOMNode; f: TStream;
Flags: TXMLReaderFlags);
begin
ReadXMLFragment(AParentNode, f, 'stream:', Flags);
@ -4199,7 +4247,7 @@ procedure ReadXMLFragment(AParentNode: TDOMNode; const AFilename: String;
var
Stream: TStream;
begin
Stream := TFileStream.Create(UTF8ToSys(AFilename), fmOpenRead+fmShareDenyWrite);
Stream := TFileStreamUTF8.Create(AFilename, fmOpenRead+fmShareDenyWrite);
try
ReadXMLFragment(AParentNode, Stream, FilenameToURI(AFilename), Flags);
finally
@ -4224,7 +4272,7 @@ begin
end;
end;
procedure ReadDTDFile(out ADoc: TXMLDocument; var f: TStream; const ABaseURI: String);
procedure ReadDTDFile(out ADoc: TXMLDocument; f: TStream; const ABaseURI: String);
var
Reader: TXMLReader;
Src: TXMLCharSource;
@ -4241,7 +4289,29 @@ begin
end;
end;
procedure ReadDTDFile(out ADoc: TXMLDocument; var f: TStream);
procedure ReadDTDFile(out ADoc: TXMLDocument; var f: File);
var
BufSize: Int64;
ms: TMemoryStream;
begin
ADoc := nil;
BufSize := FileSize(f) + 1;
if BufSize <= 1 then
exit;
ms:=TMemoryStream.Create;
try
ms.Size:=BufSize;
BlockRead(f, ms.Memory^, BufSize - 1);
PChar(ms.Memory)[BufSize - 1] := #0;
ms.Position:=0;
ReadDTDFile(ADoc,ms,'stream:');
finally
ms.Free;
end;
end;
procedure ReadDTDFile(out ADoc: TXMLDocument; f: TStream);
begin
ReadDTDFile(ADoc, f, 'stream:');
end;
@ -4251,7 +4321,7 @@ var
Stream: TStream;
begin
ADoc := nil;
Stream := TFileStream.Create(UTF8ToSys(AFilename), fmOpenRead+fmShareDenyWrite);
Stream := TFileStreamUTF8.Create(AFilename, fmOpenRead+fmShareDenyWrite);
try
ReadDTDFile(ADoc, Stream, FilenameToURI(AFilename));
finally

6
components/lazutils/laz2_xmlwrite.pas
View File

@ -27,7 +27,7 @@ unit laz2_XMLWrite;
interface
uses Classes, laz2_DOM, SysUtils, laz2_xmlutils;
uses Classes, laz2_DOM, SysUtils, laz2_xmlutils, lazutf8classes;
type
TXMLWriterFlag = (
@ -868,9 +868,9 @@ end;
procedure WriteXMLFile(doc: TXMLDocument; const AFileName: String;
Flags: TXMLWriterFlags = []);
var
fs: TFileStream;
fs: TFileStreamUTF8;
begin
fs := TFileStream.Create(UTF8ToSys(AFileName), fmCreate);
fs := TFileStreamUTF8.Create(AFileName, fmCreate);
try
WriteXMLFile(doc, fs, Flags);
finally

1696
components/lazutils/laz_dom.pas
View File

File diff suppressed because it is too large Load Diff

896
components/lazutils/laz_xmlcfg.pas
View File

@ -26,903 +26,13 @@ unit Laz_XMLCfg;
interface
{off $DEFINE MEM_CHECK}
{off $DEFINE OldXMLCfg}
uses
{$IFDEF MEM_CHECK}MemCheck,{$ENDIF}
Classes, sysutils, LazFileCache,
{$IFNDEF OldXMLCfg}
Laz2_DOM, Laz2_XMLRead, Laz2_XMLWrite,
{$ELSE}
Laz_DOM, Laz_XMLRead, Laz_XMLWrite,
{$ENDIF}
typinfo;
Classes, sysutils, Laz2_XMLCfg;
type
{"APath" is the path and name of a value: A XML configuration file is
hierachical. "/" is the path delimiter, the part after the last "/"
is the name of the value. The path components will be mapped to XML
elements, the name will be an element attribute.}
{ TXMLConfig }
TXMLConfig = class(TComponent)
private
FFilename: String;
{$IFNDEF OldXMLCfg}
FReadFlags: TXMLReaderFlags;
FWriteFlags: TXMLWriterFlags;
{$ENDIF}
procedure SetFilename(const AFilename: String);
protected
doc: TXMLDocument;
FModified: Boolean;
fDoNotLoadFromFile: boolean;
fAutoLoadFromSource: string;
fPathCache: string;
fPathNodeCache: array of TDomNode; // starting with doc.DocumentElement, then first child node of first sub path
procedure Loaded; override;
function ExtendedToStr(const e: extended): string;
function StrToExtended(const s: string; const ADefault: extended): extended;
procedure ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String); virtual;
procedure WriteXMLFile(ADoc: TXMLDocument; const AFileName: String); virtual;
procedure FreeDoc; virtual;
procedure SetPathNodeCache(Index: integer; Node: TDomNode);
function GetPathNodeCache(Index: integer): TDomNode;
procedure InvalidateCacheTilEnd(StartIndex: integer);
function InternalFindNode(const APath: String; PathLen: integer;
CreateNodes: boolean = false): TDomNode;
procedure InternalCleanNode(Node: TDomNode);
public
constructor Create(AOwner: TComponent); override;
constructor Create(const AFilename: String); overload; // create and load
constructor CreateClean(const AFilename: String); // create new
constructor CreateWithSource(const AFilename, Source: String); // create new and load from Source
destructor Destroy; override;
procedure Clear;
procedure Flush; // Writes the XML file
procedure ReadFromStream(s: TStream);
procedure WriteToStream(s: TStream);
function GetValue(const APath, ADefault: String): String;
function GetValue(const APath: String; ADefault: Integer): Integer;
function GetValue(const APath: String; ADefault: Boolean): Boolean;
function GetExtendedValue(const APath: String;
const ADefault: extended): extended;
procedure SetValue(const APath, AValue: String);
procedure SetDeleteValue(const APath, AValue, DefValue: String);
procedure SetValue(const APath: String; AValue: Integer);
procedure SetDeleteValue(const APath: String; AValue, DefValue: Integer);
procedure SetValue(const APath: String; AValue: Boolean);
procedure SetDeleteValue(const APath: String; AValue, DefValue: Boolean);
procedure SetExtendedValue(const APath: String; const AValue: extended);
procedure SetDeleteExtendedValue(const APath: String;
const AValue, DefValue: extended);
procedure DeletePath(const APath: string);
procedure DeleteValue(const APath: string);
function FindNode(const APath: String; PathHasValue: boolean): TDomNode;
function HasPath(const APath: string; PathHasValue: boolean): boolean; // checks if the path has values, set PathHasValue=true to skip the last part
function HasChildPaths(const APath: string): boolean;
property Modified: Boolean read FModified write FModified;
procedure InvalidatePathCache;
published
property Filename: String read FFilename write SetFilename;
property Document: TXMLDocument read doc;
{$IFNDEF OldXMLCfg}
property ReadFlags: TXMLReaderFlags read FReadFlags write FReadFlags;
property WriteFlags: TXMLWriterFlags read FWriteFlags write FWriteFlags;
{$ENDIF}
end;
{ TRttiXMLConfig }
TRttiXMLConfig = class(TXMLConfig)
protected
procedure WriteProperty(Path: String; Instance: TPersistent;
PropInfo: Pointer; DefInstance: TPersistent = nil;
OnlyProperty: String= '');
procedure ReadProperty(Path: String; Instance: TPersistent;
PropInfo: Pointer; DefInstance: TPersistent = nil;
OnlyProperty: String= '');
public
procedure WriteObject(Path: String; Obj: TPersistent;
DefObject: TPersistent= nil; OnlyProperty: String= '');
procedure ReadObject(Path: String; Obj: TPersistent;
DefObject: TPersistent= nil; OnlyProperty: String= '');
end;
// ===================================================================
TXMLConfig = Laz2_XMLCfg.TXMLConfig;
TRttiXMLConfig = Laz2_XMLCfg.TRttiXMLConfig;
implementation
constructor TXMLConfig.Create(AOwner: TComponent);
begin
{$IFNDEF OldXMLCfg}
// for compatibility with old TXMLConfig, which wrote #13 as #13, not as &xD;
FReadFlags:=[xrfAllowLowerThanInAttributeValue,xrfAllowSpecialCharsInAttributeValue];
// for compatibility with old TXMLConfig, which can not read &xD;, but needs #13
FWriteFlags:=[xwfSpecialCharsInAttributeValue];
{$ENDIF}
inherited Create(AOwner);
end;
constructor TXMLConfig.Create(const AFilename: String);
begin
Create(nil);
SetFilename(AFilename);
end;
constructor TXMLConfig.CreateClean(const AFilename: String);
begin
//DebugLn(['TXMLConfig.CreateClean ',AFilename]);
fDoNotLoadFromFile:=true;
Create(AFilename);
FModified:=FileExistsCached(AFilename);
end;
constructor TXMLConfig.CreateWithSource(const AFilename, Source: String);
begin
fAutoLoadFromSource:=Source;
try
CreateClean(AFilename);
finally
fAutoLoadFromSource:='';
end;
end;
destructor TXMLConfig.Destroy;
begin
if Assigned(doc) then
begin
Flush;
FreeDoc;
end;
inherited Destroy;
end;
procedure TXMLConfig.Clear;
var
cfg: TDOMElement;
begin
// free old document
FreeDoc;
// create new document
doc := TXMLDocument.Create;
cfg :=TDOMElement(doc.FindNode('CONFIG'));
if not Assigned(cfg) then begin
cfg := doc.CreateElement('CONFIG');
doc.AppendChild(cfg);
end;
end;
procedure TXMLConfig.Flush;
begin
if Modified and (Filename<>'') then
begin
//DebugLn(['TXMLConfig.Flush ',Filename]);
{$IFNDEF OldXMLCfg}
Laz2_XMLWrite.WriteXMLFile(Doc,Filename,WriteFlags);
{$ELSE}
Laz_XMLWrite.WriteXMLFile(Doc,Filename);
{$ENDIF}
InvalidateFileStateCache;
FModified := False;
end;
end;
procedure TXMLConfig.ReadFromStream(s: TStream);
begin
FreeDoc;
{$IFNDEF OldXMLCfg}
Laz2_XMLRead.ReadXMLFile(Doc,s,ReadFlags);
{$ELSE}
Laz_XMLRead.ReadXMLFile(Doc,s);
{$ENDIF}
if Doc=nil then
Clear;
end;
procedure TXMLConfig.WriteToStream(s: TStream);
begin
{$IFNDEF OldXMLCfg}
Laz2_XMLWrite.WriteXMLFile(Doc,s,WriteFlags);
{$ELSE}
Laz_XMLWrite.WriteXMLFile(Doc,s);
{$ENDIF}
end;
function TXMLConfig.GetValue(const APath, ADefault: String): String;
var
Node, Attr: TDOMNode;
NodeName: String;
StartPos: integer;
begin
//CheckHeapWrtMemCnt('TXMLConfig.GetValue A '+APath);
Result:=ADefault;
StartPos:=length(APath)+1;
while (StartPos>1) and (APath[StartPos-1]<>'/') do dec(StartPos);
if StartPos>length(APath) then exit;
Node:=InternalFindNode(APath,StartPos-1);
if Node=nil then
exit;
//CheckHeapWrtMemCnt('TXMLConfig.GetValue E');
NodeName:=copy(APath,StartPos,length(APath));
//CheckHeapWrtMemCnt('TXMLConfig.GetValue G');
Attr := Node.Attributes.GetNamedItem(NodeName);
if Assigned(Attr) then
Result := Attr.NodeValue;
//writeln('TXMLConfig.GetValue END Result="',Result,'"');
end;
function TXMLConfig.GetValue(const APath: String; ADefault: Integer): Integer;
begin
Result := StrToIntDef(GetValue(APath, IntToStr(ADefault)),ADefault);
end;
function TXMLConfig.GetValue(const APath: String; ADefault: Boolean): Boolean;
var
s: String;
begin
if ADefault then
s := 'True'
else
s := 'False';
s := GetValue(APath, s);
if CompareText(s,'TRUE')=0 then
Result := True
else if CompareText(s,'FALSE')=0 then
Result := False
else
Result := ADefault;
end;
function TXMLConfig.GetExtendedValue(const APath: String;
const ADefault: extended): extended;
begin
Result:=StrToExtended(GetValue(APath,ExtendedToStr(ADefault)),ADefault);
end;
procedure TXMLConfig.SetValue(const APath, AValue: String);
var
Node: TDOMNode;
NodeName: String;
StartPos: integer;
begin
StartPos:=length(APath)+1;
while (StartPos>1) and (APath[StartPos-1]<>'/') do dec(StartPos);
if StartPos>length(APath) then exit;
Node:=InternalFindNode(APath,StartPos-1,true);
if Node=nil then
exit;
NodeName:=copy(APath,StartPos,length(APath));
if (not Assigned(TDOMElement(Node).GetAttributeNode(NodeName))) or
(TDOMElement(Node)[NodeName] <> AValue) then
begin
TDOMElement(Node)[NodeName] := AValue;
FModified := True;
end;
end;
procedure TXMLConfig.SetDeleteValue(const APath, AValue, DefValue: String);
begin
if AValue=DefValue then
DeleteValue(APath)
else
SetValue(APath,AValue);
end;
procedure TXMLConfig.SetValue(const APath: String; AValue: Integer);
begin
SetValue(APath, IntToStr(AValue));
end;
procedure TXMLConfig.SetDeleteValue(const APath: String; AValue,
DefValue: Integer);
begin
if AValue=DefValue then
DeleteValue(APath)
else
SetValue(APath,AValue);
end;
procedure TXMLConfig.SetValue(const APath: String; AValue: Boolean);
begin
if AValue then
SetValue(APath, 'True')
else
SetValue(APath, 'False');
end;
procedure TXMLConfig.SetDeleteValue(const APath: String; AValue,
DefValue: Boolean);
begin
if AValue=DefValue then
DeleteValue(APath)
else
SetValue(APath,AValue);
end;
procedure TXMLConfig.SetExtendedValue(const APath: String;
const AValue: extended);
begin
SetValue(APath,ExtendedToStr(AValue));
end;
procedure TXMLConfig.SetDeleteExtendedValue(const APath: String; const AValue,
DefValue: extended);
begin
if AValue=DefValue then
DeleteValue(APath)
else
SetExtendedValue(APath,AValue);
end;
procedure TXMLConfig.DeletePath(const APath: string);
var
Node: TDOMNode;
ParentNode: TDOMNode;
begin
Node:=InternalFindNode(APath,length(APath));
if (Node=nil) or (Node.ParentNode=nil) then exit;
ParentNode:=Node.ParentNode;
ParentNode.RemoveChild(Node);
FModified:=true;
InvalidatePathCache;
InternalCleanNode(ParentNode);
end;
procedure TXMLConfig.DeleteValue(const APath: string);
var
Node: TDomNode;
StartPos: integer;
NodeName: string;
begin
Node:=FindNode(APath,true);
if (Node=nil) then exit;
StartPos:=length(APath);
while (StartPos>0) and (APath[StartPos]<>'/') do dec(StartPos);
NodeName:=copy(APath,StartPos+1,length(APath)-StartPos);
if Assigned(TDOMElement(Node).GetAttributeNode(NodeName)) then begin
TDOMElement(Node).RemoveAttribute(NodeName);
FModified := True;
end;
InternalCleanNode(Node);
end;
procedure TXMLConfig.Loaded;
begin
inherited Loaded;
if Length(Filename) > 0 then
SetFilename(Filename); // Load the XML config file
end;
function TXMLConfig.FindNode(const APath: String;
PathHasValue: boolean): TDomNode;
var
PathLen: Integer;
begin
PathLen:=length(APath);
if PathHasValue then begin
while (PathLen>0) and (APath[PathLen]<>'/') do dec(PathLen);
while (PathLen>0) and (APath[PathLen]='/') do dec(PathLen);
end;
Result:=InternalFindNode(APath,PathLen);
end;
function TXMLConfig.HasPath(const APath: string; PathHasValue: boolean
): boolean;
begin
Result:=FindNode(APath,PathHasValue)<>nil;
end;
function TXMLConfig.HasChildPaths(const APath: string): boolean;
var
Node: TDOMNode;
begin
Node:=FindNode(APath,false);
Result:=(Node<>nil) and Node.HasChildNodes;
end;
procedure TXMLConfig.InvalidatePathCache;
begin
fPathCache:='';
InvalidateCacheTilEnd(0);
end;
function TXMLConfig.ExtendedToStr(const e: extended): string;
var
OldDecimalSeparator: Char;
OldThousandSeparator: Char;
begin
OldDecimalSeparator:=DefaultFormatSettings.DecimalSeparator;
OldThousandSeparator:=DefaultFormatSettings.ThousandSeparator;
DefaultFormatSettings.DecimalSeparator:='.';
DefaultFormatSettings.ThousandSeparator:=',';
Result:=FloatToStr(e);
DefaultFormatSettings.DecimalSeparator:=OldDecimalSeparator;
DefaultFormatSettings.ThousandSeparator:=OldThousandSeparator;
end;
function TXMLConfig.StrToExtended(const s: string; const ADefault: extended): extended;
var
OldDecimalSeparator: Char;
OldThousandSeparator: Char;
begin
OldDecimalSeparator:=DefaultFormatSettings.DecimalSeparator;
OldThousandSeparator:=DefaultFormatSettings.ThousandSeparator;
DefaultFormatSettings.DecimalSeparator:='.';
DefaultFormatSettings.ThousandSeparator:=',';
Result:=StrToFloatDef(s,ADefault);
DefaultFormatSettings.DecimalSeparator:=OldDecimalSeparator;
DefaultFormatSettings.ThousandSeparator:=OldThousandSeparator;
end;
procedure TXMLConfig.ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String);
begin
InvalidatePathCache;
{$IFNDEF OldXMLCfg}
Laz2_XMLRead.ReadXMLFile(ADoc,AFilename,ReadFlags);
{$ELSE}
Laz_XMLRead.ReadXMLFile(ADoc,AFilename);
{$ENDIF}
end;
procedure TXMLConfig.WriteXMLFile(ADoc: TXMLDocument; const AFileName: String);
begin
{$IFNDEF OldXMLCfg}
Laz2_XMLWrite.WriteXMLFile(ADoc,AFileName,WriteFlags);
{$ELSE}
Laz_XMLWrite.WriteXMLFile(ADoc,AFileName);
{$ENDIF}
InvalidateFileStateCache(AFileName);
end;
procedure TXMLConfig.FreeDoc;
begin
InvalidatePathCache;
FreeAndNil(doc);
end;
procedure TXMLConfig.SetPathNodeCache(Index: integer; Node: TDomNode);
var
OldLength: Integer;
i: LongInt;
NewSize: Integer;
begin
OldLength:=length(fPathNodeCache);
if OldLength<=Index then begin
NewSize:=OldLength*2+4;
if NewSize<Index then NewSize:=Index;
SetLength(fPathNodeCache,NewSize);
for i:=OldLength to length(fPathNodeCache)-1 do
fPathNodeCache[i]:=nil;
end;
fPathNodeCache[Index]:=Node;
end;
function TXMLConfig.GetPathNodeCache(Index: integer): TDomNode;
begin
if Index<length(fPathNodeCache) then
Result:=fPathNodeCache[Index]
else
Result:=nil;
end;
procedure TXMLConfig.InvalidateCacheTilEnd(StartIndex: integer);
var
i: LongInt;
begin
for i:=StartIndex to length(fPathNodeCache)-1 do begin
if fPathNodeCache[i]=nil then break;
fPathNodeCache[i]:=nil;
end;
end;
function TXMLConfig.InternalFindNode(const APath: String; PathLen: integer;
CreateNodes: boolean): TDomNode;
var
NodePath: String;
StartPos, EndPos: integer;
PathIndex: Integer;
Parent: TDOMNode;
NameLen: Integer;
begin
//debugln(['TXMLConfig.InternalFindNode APath="',copy(APath,1,PathLen),'" CreateNodes=',CreateNodes]);
PathIndex:=0;
Result:=GetPathNodeCache(PathIndex);
if (Result=nil) and (doc<>nil) then begin
Result:=TDOMElement(doc.FindNode('CONFIG'));
SetPathNodeCache(PathIndex,Result);
end;
if PathLen=0 then exit;
StartPos:=1;
while (Result<>nil) do begin
EndPos:=StartPos;
while (EndPos<=PathLen) and (APath[EndPos]<>'/') do inc(EndPos);
NameLen:=EndPos-StartPos;
if NameLen=0 then break;
inc(PathIndex);
Parent:=Result;
Result:=GetPathNodeCache(PathIndex);
if (Result<>nil) and (length(Result.NodeName)=NameLen)
and CompareMem(PChar(Result.NodeName),@APath[StartPos],NameLen) then begin
// cache valid
end else begin
// different path => search
InvalidateCacheTilEnd(PathIndex);
NodePath:=copy(APath,StartPos,NameLen);
Result:=Parent.FindNode(NodePath);
if Result=nil then begin
if not CreateNodes then exit;
// create missing node
Result := Doc.CreateElement(NodePath);
Parent.AppendChild(Result);
if EndPos>PathLen then exit;
end;
SetPathNodeCache(PathIndex,Result);
end;
StartPos:=EndPos+1;
if StartPos>PathLen then exit;
end;
Result:=nil;
end;
procedure TXMLConfig.InternalCleanNode(Node: TDomNode);
var
ParentNode: TDOMNode;
begin
if (Node=nil) then exit;
while (Node.FirstChild=nil) and (Node.ParentNode<>nil)
and (Node.ParentNode.ParentNode<>nil) do begin
if (Node is TDOMElement) and (not TDOMElement(Node).IsEmpty) then break;
ParentNode:=Node.ParentNode;
ParentNode.RemoveChild(Node);
InvalidatePathCache;
Node:=ParentNode;
FModified := True;
end;
end;
procedure TXMLConfig.SetFilename(const AFilename: String);
var
cfg: TDOMElement;
ms: TMemoryStream;
begin
{$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLConfig.SetFilename A '+AFilename);{$ENDIF}
if FFilename = AFilename then exit;
FFilename := AFilename;
InvalidatePathCache;
if csLoading in ComponentState then
exit;
if Assigned(doc) then
begin
Flush;
FreeDoc;
end;
doc:=nil;
//debugln(['TXMLConfig.SetFilename Load=',not fDoNotLoadFromFile,' FileExists=',FileExistsCached(Filename),' File=',Filename]);
if (not fDoNotLoadFromFile) and FileExistsCached(Filename) then
{$IFNDEF OldXMLCfg}
Laz2_XMLRead.ReadXMLFile(doc,Filename,ReadFlags)
{$ELSE}
Laz_XMLRead.ReadXMLFile(doc,Filename)
{$ENDIF}
else if fAutoLoadFromSource<>'' then begin
ms:=TMemoryStream.Create;
try
ms.Write(fAutoLoadFromSource[1],length(fAutoLoadFromSource));
ms.Position:=0;
{$IFNDEF OldXMLCfg}
Laz2_XMLRead.ReadXMLFile(doc,ms,ReadFlags);
{$ELSE}
Laz_XMLRead.ReadXMLFile(doc,ms);
{$ENDIF}
finally
ms.Free;
end;
end;
if not Assigned(doc) then
doc := TXMLDocument.Create;
cfg :=TDOMElement(doc.FindNode('CONFIG'));
//debugln(['TXMLConfig.SetFilename cfg=',DbgSName(cfg),' doc=',DbgSName(doc)]);
if not Assigned(cfg) then begin
cfg := doc.CreateElement('CONFIG');
doc.AppendChild(cfg);
end;
{$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLConfig.SetFilename END');{$ENDIF}
end;
{ TRttiXMLConfig }
procedure TRttiXMLConfig.WriteObject(Path: String; Obj: TPersistent;
DefObject: TPersistent; OnlyProperty: String = '');
var
PropCount,i : integer;
PropList : PPropList;
begin
PropCount:=GetPropList(Obj,PropList);
if PropCount>0 then begin
try
for i := 0 to PropCount-1 do
WriteProperty(Path, Obj, PropList^[i], DefObject, OnlyProperty);
finally
Freemem(PropList);
end;
end;
end;
// based on FPC TWriter
procedure TRttiXMLConfig.WriteProperty(Path: String; Instance: TPersistent;
PropInfo: Pointer; DefInstance: TPersistent; OnlyProperty: String= '');
type
tset = set of 0..31;
var
i: Integer;
PropType: PTypeInfo;
Value, DefValue: LongInt;
Ident: String;
IntToIdentFn: TIntToIdent;
SetType: Pointer;
FloatValue, DefFloatValue: Extended;
//WStrValue, WDefStrValue: WideString;
StrValue, DefStrValue: String;
//Int64Value, DefInt64Value: Int64;
BoolValue, DefBoolValue: boolean;
begin
// do not stream properties without getter and setter
if not (Assigned(PPropInfo(PropInfo)^.GetProc) and
Assigned(PPropInfo(PropInfo)^.SetProc)) then
exit;
PropType := PPropInfo(PropInfo)^.PropType;
Path := Path + PPropInfo(PropInfo)^.Name;
if (OnlyProperty <> '') and (OnlyProperty <> PPropInfo(PropInfo)^.Name) then
exit;
case PropType^.Kind of
tkInteger, tkChar, tkEnumeration, tkSet, tkWChar:
begin
Value := GetOrdProp(Instance, PropInfo);
if (DefInstance <> nil) then
DefValue := GetOrdProp(DefInstance, PropInfo);
if (DefInstance <> nil) and (Value = DefValue) then
DeleteValue(Path)
else begin
case PropType^.Kind of
tkInteger:
begin // Check if this integer has a string identifier
IntToIdentFn := FindIntToIdent(PPropInfo(PropInfo)^.PropType);
if Assigned(IntToIdentFn) and IntToIdentFn(Value, Ident{%H-}) then
SetValue(Path, Ident) // Integer can be written a human-readable identifier
else
SetValue(Path, Value); // Integer has to be written just as number
end;
tkChar:
SetValue(Path, Chr(Value));
tkWChar:
SetValue(Path, Value);
tkSet:
begin
SetType := GetTypeData(PropType)^.CompType;
Ident := '';
for i := 0 to 31 do
if (i in tset(Value)) then begin
if Ident <> '' then Ident := Ident + ',';
Ident := Ident + GetEnumName(PTypeInfo(SetType), i);
end;
SetValue(Path, Ident);
end;
tkEnumeration:
SetValue(Path, GetEnumName(PropType, Value));
end;
end;
end;
tkFloat:
begin
FloatValue := GetFloatProp(Instance, PropInfo);
if (DefInstance <> nil) then
DefFloatValue := GetFloatProp(DefInstance, PropInfo);
if (DefInstance <> nil) and (DefFloatValue = FloatValue) then
DeleteValue(Path)
else
SetValue(Path, FloatToStr(FloatValue));
end;
tkSString, tkLString, tkAString:
begin
StrValue := GetStrProp(Instance, PropInfo);
if (DefInstance <> nil) then
DefStrValue := GetStrProp(DefInstance, PropInfo);
if (DefInstance <> nil) and (DefStrValue = StrValue) then
DeleteValue(Path)
else
SetValue(Path, StrValue);
end;
(* tkWString:
begin
WStrValue := GetWideStrProp(Instance, PropInfo);
if (DefInstance <> nil) then
WDefStrValue := GetWideStrProp(DefInstance, PropInfo);
if (DefInstance <> nil) and (WDefStrValue = WStrValue) then
DeleteValue(Path)
else
SetValue(Path, WStrValue);
end;*)
(* tkInt64, tkQWord:
begin
Int64Value := GetInt64Prop(Instance, PropInfo);
if (DefInstance <> nil) then
DefInt64Value := GetInt64Prop(DefInstance, PropInfo)
if (DefInstance <> nil) and (Int64Value = DefInt64Value) then
DeleteValue(Path, Path)
else
SetValue(StrValue);
end;*)
tkBool:
begin
BoolValue := GetOrdProp(Instance, PropInfo)<>0;
if (DefInstance <> nil) then
DefBoolValue := GetOrdProp(DefInstance, PropInfo)<>0;
if (DefInstance <> nil) and (BoolValue = DefBoolValue) then
DeleteValue(Path)
else
SetValue(Path, BoolValue);
end;
end;
end;
procedure TRttiXMLConfig.ReadProperty(Path: String; Instance: TPersistent; PropInfo: Pointer;
DefInstance: TPersistent; OnlyProperty: String);
type
tset = set of 0..31;
var
i, j: Integer;
PropType: PTypeInfo;
Value, DefValue: LongInt;
Ident, s: String;
IdentToIntFn: TIdentToInt;
SetType: Pointer;
FloatValue, DefFloatValue: Extended;
//WStrValue, WDefStrValue: WideString;
StrValue, DefStrValue: String;
//Int64Value, DefInt64Value: Int64;
BoolValue, DefBoolValue: boolean;
begin
// do not stream properties without getter and setter
if not (Assigned(PPropInfo(PropInfo)^.GetProc) and
Assigned(PPropInfo(PropInfo)^.SetProc)) then
exit;
PropType := PPropInfo(PropInfo)^.PropType;
Path := Path + PPropInfo(PropInfo)^.Name;
if (OnlyProperty <> '') and (OnlyProperty <> PPropInfo(PropInfo)^.Name) then
exit;
if DefInstance = nil then
DefInstance := Instance;
case PropType^.Kind of
tkInteger, tkChar, tkEnumeration, tkSet, tkWChar:
begin
DefValue := GetOrdProp(DefInstance, PropInfo);
case PropType^.Kind of
tkInteger:
begin // Check if this integer has a string identifier
Ident := GetValue(Path, IntToStr(DefValue));
IdentToIntFn := FindIdentToInt(PPropInfo(PropInfo)^.PropType);
if TryStrToInt(Ident, Value) then
SetOrdProp(Instance, PropInfo, Value)
else if Assigned(IdentToIntFn) and IdentToIntFn(Ident, Value) then
SetOrdProp(Instance, PropInfo, Value)
else
SetOrdProp(Instance, PropInfo, DefValue)
end;
tkChar:
begin
Ident := GetValue(Path, chr(DefValue));
if Length(Ident) > 0 then
SetOrdProp(Instance, PropInfo, ord(Ident[1]))
else
SetOrdProp(Instance, PropInfo, DefValue);
end;
tkWChar:
SetOrdProp(Instance, PropInfo, GetValue(Path, DefValue));
tkSet:
begin
SetType := GetTypeData(PropType)^.CompType;
Ident := GetValue(Path, '-');
If Ident = '-' then
Value := DefValue
else begin
Value := 0;
while length(Ident) > 0 do begin
i := Pos(',', Ident);
if i < 1 then
i := length(Ident) + 1;
s := copy(Ident, 1, i-1);
Ident := copy(Ident, i+1, length(Ident));
j := GetEnumValue(PTypeInfo(SetType), s);
if j <> -1 then
include(tset(Value), j)
else Begin
Value := DefValue;
break;
end;
end;
end;
SetOrdProp(Instance, PropInfo, Value);
end;
tkEnumeration:
begin
Ident := GetValue(Path, '-');
If Ident = '-' then
Value := DefValue
else
Value := GetEnumValue(PropType, Ident);
if Value <> -1 then
SetOrdProp(Instance, PropInfo, Value)
else
SetOrdProp(Instance, PropInfo, DefValue);
end;
end;
end;
tkFloat:
begin
DefFloatValue := GetFloatProp(DefInstance, PropInfo);
Ident := GetValue(Path, FloatToStr(DefFloatValue));
if TryStrToFloat(Ident, FloatValue) then
SetFloatProp(Instance, PropInfo, FloatValue)
else
SetFloatProp(Instance, PropInfo, DefFloatValue)
end;
tkSString, tkLString, tkAString:
begin
DefStrValue := GetStrProp(DefInstance, PropInfo);
StrValue := GetValue(Path, DefStrValue);
SetStrProp(Instance, PropInfo, StrValue)
end;
(* tkWString:
begin
end;*)
(* tkInt64, tkQWord:
begin
end;*)
tkBool:
begin
DefBoolValue := GetOrdProp(DefInstance, PropInfo) <> 0;
BoolValue := GetValue(Path, DefBoolValue);
SetOrdProp(Instance, PropInfo, ord(BoolValue));
end;
end;
end;
procedure TRttiXMLConfig.ReadObject(Path: String; Obj: TPersistent; DefObject: TPersistent;
OnlyProperty: String);
var
PropCount,i : integer;
PropList : PPropList;
begin
PropCount:=GetPropList(Obj,PropList);
if PropCount>0 then begin
try
for i := 0 to PropCount-1 do
ReadProperty(Path, Obj, PropList^[i], DefObject, OnlyProperty);
finally
Freemem(PropList);
end;
end;
end;
end.

1515
components/lazutils/laz_xmlread.pas
View File

File diff suppressed because it is too large Load Diff

574
components/lazutils/laz_xmlwrite.pas
View File

@ -1,28 +1,14 @@
{
$Id$
This file is part of the Free Component Library
XML writing routines
Copyright (c) 1999-2000 by Sebastian Guenther, sg@freepascal.org
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit Laz_XMLWrite;
{$MODE objfpc}
{$H+}
{$MODE objfpc}{$H+}
{$inline on}
interface
uses Classes, LazUTF8, Laz_DOM;
uses Classes, laz2_XMLWrite, laz2_DOM;
const
xwfOldXMLWrite = [xwfSpecialCharsInAttributeValue];
procedure WriteXMLFile(doc: TXMLDocument; const AFileName: String); overload;
procedure WriteXMLFile(doc: TXMLDocument; var AFile: Text); overload;
@ -32,572 +18,36 @@ procedure WriteXML(Element: TDOMNode; const AFileName: String); overload;
procedure WriteXML(Element: TDOMNode; var AFile: Text); overload;
procedure WriteXML(Element: TDOMNode; AStream: TStream); overload;
// ===================================================================
implementation
uses SysUtils;
// -------------------------------------------------------------------
// Writers for the different node types
// -------------------------------------------------------------------
procedure WriteElement(node: TDOMNode); forward;
procedure WriteAttribute(node: TDOMNode); forward;
procedure WriteText(node: TDOMNode); forward;
procedure WriteCDATA(node: TDOMNode); forward;
procedure WriteEntityRef(node: TDOMNode); forward;
procedure WriteEntity(node: TDOMNode); forward;
procedure WritePI(node: TDOMNode); forward;
procedure WriteComment(node: TDOMNode); forward;
procedure WriteDocument(node: TDOMNode); forward;
procedure WriteDocumentType(node: TDOMNode); forward;
procedure WriteDocumentFragment(node: TDOMNode); forward;
procedure WriteNotation(node: TDOMNode); forward;
function NodeFrontIsText(Node: TDOMNode): boolean;
begin
Result:=(Node is TDOMText) or (Node.ParentNode is TDOMText)
or (Node.PreviousSibling is TDOMText);
end;
function NodeAfterIsText(Node: TDOMNode): boolean;
begin
Result:=(Node is TDOMText) or (Node.ParentNode is TDOMText)
or (Node.NextSibling is TDOMText);
end;
type
TWriteNodeProc = procedure(node: TDOMNode);
const
WriteProcs: array[ELEMENT_NODE..NOTATION_NODE] of TWriteNodeProc =
(@WriteElement, @WriteAttribute, @WriteText, @WriteCDATA, @WriteEntityRef,
@WriteEntity, @WritePI, @WriteComment, @WriteDocument, @WriteDocumentType,
@WriteDocumentFragment, @WriteNotation);
LineEnd: shortstring = LineEnding;
procedure WriteNode(node: TDOMNode);
begin
WriteProcs[node.NodeType](node);
end;
// -------------------------------------------------------------------
// Text file and TStream support
// -------------------------------------------------------------------
type
TOutputProc = procedure(const Buffer; Count: Longint);
threadvar
f: ^Text;
stream: TStream;
wrt, wrtln: TOutputProc;
procedure Text_Write(const Buffer; Count: Longint);
var s: string;
begin
if Count>0 then begin
SetLength(s,Count);
System.Move(Buffer,s[1],Count);
Write(f^, s);
end;
end;
procedure Text_WriteLn(const Buffer; Count: Longint);
var s: string;
begin
if Count>0 then begin
SetLength(s,Count);
System.Move(Buffer,s[1],Count);
writeln(f^, s);
end;
end;
procedure Stream_Write(const Buffer; Count: Longint);
begin
if Count > 0 then begin
stream.Write(Buffer, Count);
end;
end;
procedure Stream_WriteLn(const Buffer; Count: Longint);
begin
if Count > 0 then begin
stream.Write(Buffer, Count);
stream.Write(LineEnd[1],length(LineEnd));
end;
end;
procedure wrtStr(const s: string);
begin
if s<>'' then
wrt(s[1],length(s));
end;
procedure wrtStrLn(const s: string);
begin
if s<>'' then
wrtln(s[1],length(s));
end;
procedure wrtChr(c: char);
begin
wrt(c,1);
end;
procedure wrtLineEnd;
begin
wrt(LineEnd[1],length(LineEnd));
end;
// -------------------------------------------------------------------
// Indent handling
// -------------------------------------------------------------------
threadvar
Indent: String;
IndentCount: integer;
procedure wrtIndent;
var i: integer;
begin
for i:=1 to IndentCount do
wrtStr(Indent);
end;
procedure IncIndent;
begin
inc(IndentCount);
end;
procedure DecIndent;
begin
if IndentCount>0 then dec(IndentCount);
end;
// -------------------------------------------------------------------
// String conversion
// -------------------------------------------------------------------
type
TCharacters = set of Char;
TSpecialCharCallback = procedure(c: Char);
const
AttrSpecialChars = ['<', '>', '"', '&'];
TextSpecialChars = ['<', '>', '&'];
procedure ConvWrite(const s: String; const SpecialChars: TCharacters;
const SpecialCharCallback: TSpecialCharCallback);
var
StartPos, EndPos: Integer;
begin
StartPos := 1;
EndPos := 1;
while EndPos <= Length(s) do
begin
if s[EndPos] in SpecialChars then
begin
wrt(s[StartPos],EndPos - StartPos);
SpecialCharCallback(s[EndPos]);
StartPos := EndPos + 1;
end;
Inc(EndPos);
end;
if StartPos <= length(s) then
wrt(s[StartPos], EndPos - StartPos);
end;
procedure AttrSpecialCharCallback(c: Char);
const
QuotStr = '&quot;';
AmpStr = '&amp;';
begin
if c = '"' then
wrtStr(QuotStr)
else if c = '&' then
wrtStr(AmpStr)
else
wrt(c,1);
end;
procedure TextnodeSpecialCharCallback(c: Char);
const
ltStr = '&lt;';
gtStr = '&gt;';
AmpStr = '&amp;';
begin
if c = '<' then
wrtStr(ltStr)
else if c = '>' then
wrtStr(gtStr)
else if c = '&' then
wrtStr(AmpStr)
else
wrt(c,1);
end;
// -------------------------------------------------------------------
// Node writers implementations
// -------------------------------------------------------------------
procedure WriteElement(node: TDOMNode);
var
i: Integer;
attr, child: TDOMNode;
s: String;
begin
if not NodeFrontIsText(Node) then
wrtIndent;
wrtChr('<');
wrtStr(node.NodeName);
if not (node.IsEmpty) then begin
for i := 0 to node.Attributes.Length - 1 do
begin
attr := node.Attributes.Item[i];
wrtChr(' ');
wrtStr(attr.NodeName);
wrtChr('=');
s := attr.NodeValue;
// !!!: Replace special characters in "s" such as '&', '<', '>'
wrtChr('"');
ConvWrite(s, AttrSpecialChars, @AttrSpecialCharCallback);
wrtChr('"');
end;
end;
Child := node.FirstChild;
if Child = nil then begin
wrtChr('/');
wrtChr('>');
if not NodeAfterIsText(Node) then
wrtLineEnd;
end else
begin
wrtChr('>');
if not ((Node is TDOMText) or (Node.ParentNode is TDOMText) or
(Child is TDOMText))
then
wrtLineEnd;
IncIndent;
repeat
WriteNode(Child);
Child := Child.NextSibling;
until child = nil;
DecIndent;
if not ((Node is TDOMText) or (Node.ParentNode is TDOMText) or
(Node.LastChild is TDOMText))
then
wrtIndent;
wrtChr('<');
wrtChr('/');
wrtStr(node.NodeName);
wrtChr('>');
if not NodeAfterIsText(Node) then
wrtLineEnd;
end;
end;
procedure WriteAttribute(node: TDOMNode);
begin
if node=nil then ;
end;
procedure WriteText(node: TDOMNode);
begin
ConvWrite(node.NodeValue, TextSpecialChars, @TextnodeSpecialCharCallback);
if node=nil then ;
end;
procedure WriteCDATA(node: TDOMNode);
begin
if not NodeFrontIsText(Node) then
wrtStr('<![CDATA[' + node.NodeValue + ']]>')
else begin
wrtIndent;
wrtStrln('<![CDATA[' + node.NodeValue + ']]>')
end;
end;
procedure WriteEntityRef(node: TDOMNode);
begin
wrtChr('&');
wrtStr(node.NodeName);
wrtChr(';');
end;
procedure WriteEntity(node: TDOMNode);
begin
if node=nil then ;
end;
procedure WritePI(node: TDOMNode);
begin
if not NodeFrontIsText(Node) then wrtIndent;
wrtChr('<'); wrtChr('!');
wrtStr(TDOMProcessingInstruction(node).Target);
wrtChr(' ');
wrtStr(TDOMProcessingInstruction(node).Data);
wrtChr('>');
if not NodeAfterIsText(Node) then wrtLineEnd;
end;
procedure WriteComment(node: TDOMNode);
begin
if not NodeFrontIsText(Node) then wrtIndent;
wrtStr('<!--');
wrtStr(node.NodeValue);
wrtStr('-->');
if not NodeAfterIsText(Node) then wrtLineEnd;
end;
procedure WriteDocument(node: TDOMNode);
begin
if node=nil then ;
end;
procedure WriteDocumentType(node: TDOMNode);
begin
if node=nil then ;
end;
procedure WriteDocumentFragment(node: TDOMNode);
begin
if node=nil then ;
end;
procedure WriteNotation(node: TDOMNode);
begin
if node=nil then ;
end;
procedure InitWriter;
begin
SetLength(Indent, 0);
end;
procedure RootWriter(doc: TXMLDocument);
var
Child: TDOMNode;
begin
InitWriter;
wrtStr('<?xml version="');
if Length(doc.XMLVersion) > 0 then
ConvWrite(doc.XMLVersion, AttrSpecialChars, @AttrSpecialCharCallback)
else
wrtStr('1.0');
wrtChr('"');
if Length(doc.Encoding) > 0 then
begin
wrtStr(' encoding="');
ConvWrite(doc.Encoding, AttrSpecialChars, @AttrSpecialCharCallback);
wrtStr('"');
end;
wrtStrln('?>');
if Length(doc.StylesheetType) > 0 then
begin
wrtStr('<?xml-stylesheet type="');
ConvWrite(doc.StylesheetType, AttrSpecialChars, @AttrSpecialCharCallback);
wrtStr('" href="');
ConvWrite(doc.StylesheetHRef, AttrSpecialChars, @AttrSpecialCharCallback);
wrtStrln('"?>');
end;
Indent := ' ';
IndentCount := 0;
child := doc.FirstChild;
while Assigned(Child) do
begin
WriteNode(Child);
Child := Child.NextSibling;
end;
end;
procedure WriteXMLMemStream(doc: TXMLDocument);
// internally used by the WriteXMLFile procedures
begin
Stream:=TMemoryStream.Create;
WriteXMLFile(doc,Stream);
Stream.Position:=0;
end;
// -------------------------------------------------------------------
// Interface implementation
// -------------------------------------------------------------------
{$IFDEF FPC}
// widestrings ansistring conversion is slow and we only use ansistring anyway
{off $DEFINE UsesFPCWidestrings}
{$ENDIF}
{$IFDEF UsesFPCWidestrings}
procedure SimpleWide2AnsiMove(source:pwidechar;dest:pchar;len:sizeint);
var
i : sizeint;
begin
for i:=1 to len do
begin
if word(source^)<256 then
dest^:=char(word(source^))
else
dest^:='?';
inc(dest);
inc(source);
end;
end;
procedure SimpleAnsi2WideMove(source:pchar;dest:pwidechar;len:sizeint);
var
i : sizeint;
begin
for i:=1 to len do
begin
dest^:=widechar(byte(source^));
inc(dest);
inc(source);
end;
end;
const
WideStringManager: TWideStringManager = (
Wide2AnsiMove: @SimpleWide2AnsiMove;
Ansi2WideMove: @SimpleAnsi2WideMove
);
{$ENDIF}
procedure WriteXMLFile(doc: TXMLDocument; const AFileName: String);
var
fs: TFileStream;
begin
// write first to memory buffer and then as one whole block to file
WriteXMLMemStream(doc);
try
fs := TFileStream.Create(UTF8ToSys(AFileName), fmCreate);
fs.CopyFrom(Stream,Stream.Size);
fs.Free;
finally
Stream.Free;
end;
laz2_XMLWrite.WriteXMLFile(doc,AFileName,xwfOldXMLWrite);
end;
procedure WriteXMLFile(doc: TXMLDocument; var AFile: Text);
{$IFDEF UsesFPCWidestrings}
var
OldWideStringManager: TWideStringManager;
{$ENDIF}
begin
{$IFDEF UsesFPCWidestrings}
SetWideStringManager(WideStringManager, OldWideStringManager);
try
{$ENDIF}
f := @AFile;
wrt := @Text_Write;
wrtln := @Text_WriteLn;
RootWriter(doc);
{$IFDEF UsesFPCWidestrings}
finally
SetWideStringManager(OldWideStringManager);
end;
{$ENDIF}
laz2_XMLWrite.WriteXMLFile(doc,AFile,xwfOldXMLWrite);
end;
procedure WriteXMLFile(doc: TXMLDocument; AStream: TStream);
{$IFDEF UsesFPCWidestrings}
var
OldWideStringManager: TWideStringManager;
{$ENDIF}
begin
{$IFDEF UsesFPCWidestrings}
SetWideStringManager(WideStringManager, OldWideStringManager);
try
{$ENDIF}
Stream := AStream;
wrt := @Stream_Write;
wrtln := @Stream_WriteLn;
RootWriter(doc);
{$IFDEF UsesFPCWidestrings}
finally
SetWideStringManager(OldWideStringManager);
end;
{$ENDIF}
laz2_XMLWrite.WriteXMLFile(doc,AStream,xwfOldXMLWrite);
end;
procedure WriteXML(Element: TDOMNode; const AFileName: String);
{$IFDEF UsesFPCWidestrings}
var
OldWideStringManager: TWideStringManager;
{$ENDIF}
begin
{$IFDEF UsesFPCWidestrings}
SetWideStringManager(WideStringManager, OldWideStringManager);
try
{$ENDIF}
Stream := TFileStream.Create(UTF8ToSys(AFileName), fmCreate);
wrt := @Stream_Write;
wrtln := @Stream_WriteLn;
InitWriter;
WriteNode(Element);
Stream.Free;
{$IFDEF UsesFPCWidestrings}
finally
SetWideStringManager(OldWideStringManager);
end;
{$ENDIF}
laz2_XMLWrite.WriteXML(Element,AFileName,xwfOldXMLWrite);
end;
procedure WriteXML(Element: TDOMNode; var AFile: Text);
{$IFDEF UsesFPCWidestrings}
var
OldWideStringManager: TWideStringManager;
{$ENDIF}
begin
{$IFDEF UsesFPCWidestrings}
SetWideStringManager(WideStringManager, OldWideStringManager);
try
{$ENDIF}
f := @AFile;
wrt := @Text_Write;
wrtln := @Text_WriteLn;
InitWriter;
WriteNode(Element);
{$IFDEF UsesFPCWidestrings}
finally
SetWideStringManager(OldWideStringManager);
end;
{$ENDIF}
laz2_XMLWrite.WriteXML(Element,AFile,xwfOldXMLWrite);
end;
procedure WriteXML(Element: TDOMNode; AStream: TStream);
{$IFDEF UsesFPCWidestrings}
var
OldWideStringManager: TWideStringManager;
{$ENDIF}
begin
{$IFDEF UsesFPCWidestrings}
SetWideStringManager(WideStringManager, OldWideStringManager);
try
{$ENDIF}
stream := AStream;
wrt := @Stream_Write;
wrtln := @Stream_WriteLn;
InitWriter;
WriteNode(Element);
{$IFDEF UsesFPCWidestrings}
finally
SetWideStringManager(OldWideStringManager);
end;
{$ENDIF}
laz2_XMLWrite.WriteXML(Element,AStream,xwfOldXMLWrite);
end;
end.