paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-25 16:09:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

--- Merging r29761 into '.':

Browse Source 
U    packages/fcl-xml/src/dom.pp
U    packages/fcl-xml/src/xmlread.pp
--- Recording mergeinfo for merge of r29761 into '.':
 U   .
--- Merging r30323 into '.':
U    packages/fcl-xml/src/xmlconf.pp
--- Recording mergeinfo for merge of r30323 into '.':
 G   .
--- Merging r30324 into '.':
A    packages/fcl-xml/tests/testxmlconf.lpr
A    packages/fcl-xml/tests/testxmlconf.lpi
--- Recording mergeinfo for merge of r30324 into '.':
 G   .

# revisions: 29761,30323,30324

git-svn-id: branches/fixes_3_0@31070 -
This commit is contained in:
marco 2015-06-16 19:37:35 +00:00
parent 15627a8c4b
commit 734d1d4949
6 changed files with 167 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -3189,6 +3189,8 @@ packages/fcl-xml/tests/readertest.pp svneol=native#text/plain
packages/fcl-xml/tests/readerunit.pp svneol=native#text/plain
packages/fcl-xml/tests/template.xml svneol=native#text/plain
packages/fcl-xml/tests/testgen.pp svneol=native#text/plain
packages/fcl-xml/tests/testxmlconf.lpi svneol=native#text/plain
packages/fcl-xml/tests/testxmlconf.lpr svneol=native#text/plain
packages/fcl-xml/tests/xmlts.pp svneol=native#text/plain
packages/fcl-xml/tests/xpathts.pp svneol=native#text/plain
packages/fftw/Makefile svneol=native#text/plain

13
packages/fcl-xml/src/dom.pp
View File

@ -223,7 +223,6 @@ type
procedure SetPrefix(const Value: DOMString); virtual;
function GetOwnerDocument: TDOMDocument; virtual;
function GetBaseURI: DOMString;
procedure SetReadOnly(Value: Boolean);
procedure Changing;
public
constructor Create(AOwner: TDOMDocument);
@ -270,6 +269,7 @@ type
function CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; virtual;
function FindNode(const ANodeName: DOMString): TDOMNode; virtual;
function CompareName(const name: DOMString): Integer; virtual;
procedure SetReadOnly(Value: Boolean);
property Flags: TNodeFlags read FFlags;
end;
@ -312,6 +312,8 @@ type
public
property InputEncoding: DOMString read FInputEncoding;
property XMLEncoding: DOMString read FXMLEncoding;
// extension
procedure SetHeaderData(aXmlVersion: TXMLVersion; const aXmlEncoding: DOMString);
end;
// -------------------------------------------------------
@ -695,6 +697,8 @@ type
property PublicID: DOMString read GetPublicID;
property SystemID: DOMString read GetSystemID;
property InternalSubset: DOMString read GetInternalSubset;
// extension
property Model: TDTDModel read FModel;
end;
@ -2114,6 +2118,13 @@ begin
Result := xmlVersionStr[FXMLVersion];
end;
procedure TDOMNode_TopLevel.SetHeaderData(aXmlVersion: TXMLVersion; const aXmlEncoding: DOMString);
begin
if aXmlVersion <> xmlVersionUnknown then
FXMLVersion := aXmlVersion;
FXMLEncoding := aXmlEncoding;
end;
// -------------------------------------------------------
// DOMImplementation
// -------------------------------------------------------

73
packages/fcl-xml/src/xmlconf.pp
View File

@ -32,7 +32,7 @@ uses
SysUtils, Classes, DOM, XMLRead, XMLWrite;
resourcestring
SWrongRootName = 'XML file has wrong root element name';
SWrongRootName = 'XML file has wrong root element name: expected "%s" but was "%s"';
type
EXMLConfigError = class(Exception);
@ -76,7 +76,10 @@ type
procedure OpenKey(const aPath: DOMString);
procedure CloseKey;
procedure ResetKey;
procedure SaveToFile(AFileName: string);
procedure SaveToFile(Const AFileName: string);
procedure SaveToStream(S : TStream);
procedure LoadFromFile(Const AFileName: string);
procedure LoadFromStream(S : TStream);
function GetValue(const APath: DOMString; const ADefault: DOMString): DOMString; overload;
function GetValue(const APath: DOMString; ADefault: Integer): Integer; overload;
@ -130,20 +133,54 @@ end;
procedure TXMLConfig.Flush;
begin
if Modified and not FReadOnly then
begin
SaveToFile(FFilename)
if (FFileName<>'') then
SaveToFile(FFilename)
end;
procedure TXMLConfig.SaveToFile(const AFileName: string);
Var
F : TFileStream;
begin
F:=TFileStream.Create(AFileName,fmCreate);
try
SaveToStream(F);
FFileName:=AFileName;
finally
F.Free;
end;
end;
procedure TXMLConfig.SaveToFile(AFileName: string);
procedure TXMLConfig.SaveToStream(S: TStream);
begin
if AFileName <> '' then
begin
WriteXMLFile(Doc, AFilename);
FModified := False;
WriteXMLFile(Doc,S);
FModified := False;
end;
procedure TXMLConfig.LoadFromFile(const AFileName: string);
Var
F : TFileStream;
begin
F:=TFileStream.Create(AFileName,fmOpenread or fmShareDenyWrite);
try
ReadXMLFile(Doc, AFilename);
FFileName:=AFileName;
finally
F.Free;
end;
end;
procedure TXMLConfig.LoadFromStream(S: TStream);
begin
ReadXMLFile(Doc,S);
FModified := False;
if (Doc.DocumentElement.NodeName<>FRootName) then
raise EXMLConfigError.CreateFmt(SWrongRootName,[FRootName,Doc.DocumentElement.NodeName]);
end;
function TXMLConfig.GetValue(const APath: DOMString; const ADefault: DOMString): DOMString;
var
Node: TDOMElement;
@ -364,24 +401,16 @@ begin
Flush;
FreeAndNil(Doc);
FFilename := AFilename;
if csLoading in ComponentState then
exit;
if FileExists(AFilename) and not FStartEmpty then
ReadXMLFile(Doc, AFilename);
if not Assigned(Doc) then
LoadFromFile(AFilename)
else if not Assigned(Doc) then
begin
FFileName:=AFileName;
Doc := TXMLDocument.Create;
if not Assigned(Doc.DocumentElement) then
Doc.AppendChild(Doc.CreateElement(FRootName))
else
if Doc.DocumentElement.NodeName <> FRootName then
raise EXMLConfigError.Create(SWrongRootName);
end;
end;
procedure TXMLConfig.SetFilename(const AFilename: String);

29
packages/fcl-xml/src/xmlread.pp
View File

@ -91,11 +91,6 @@ uses
UriParser, dtdmodel;
type
TDOMDocumentTypeEx = class(TDOMDocumentType);
TXMLDocumentEx = class(TXMLDocument);
TDOMEntityEx = class(TDOMEntity);
TLoader = object
doc: TDOMDocument;
reader: TXMLTextReader;
@ -237,23 +232,23 @@ end;
procedure TLoader.ProcessFragment(AOwner: TDOMNode; AReader: TXMLTextReader);
var
DoctypeNode: TDOMDocumentTypeEx;
DoctypeNode: TDOMDocumentType;
begin
doc := AOwner.OwnerDocument;
reader := AReader;
reader.OnEntity := @ProcessEntity;
reader.FragmentMode := True;
reader.XML11 := doc.XMLVersion = '1.1';
DoctypeNode := TDOMDocumentTypeEx(doc.DocType);
DoctypeNode := doc.DocType;
if Assigned(DoctypeNode) then
reader.DtdSchemaInfo := DocTypeNode.FModel.Reference;
reader.DtdSchemaInfo := DocTypeNode.Model.Reference;
ParseContent(aOwner as TDOMNode_WithChildren);
end;
procedure TLoader.ProcessEntity(Sender: TXMLTextReader; AEntity: TEntityDecl);
var
DoctypeNode: TDOMDocumentType;
Ent: TDOMEntityEx;
Ent: TDOMEntity;
src: TXMLCharSource;
InnerReader: TXMLTextReader;
InnerLoader: TLoader;
@ -261,7 +256,7 @@ begin
DoctypeNode := TDOMDocument(doc).DocType;
if DoctypeNode = nil then
Exit;
Ent := TDOMEntityEx(DocTypeNode.Entities.GetNamedItem(AEntity.FName));
Ent := TDOMEntity(DocTypeNode.Entities.GetNamedItem(AEntity.FName));
if Ent = nil then
Exit;
Sender.EntityToSource(AEntity, Src);
@ -291,18 +286,8 @@ begin
if not reader.Read then
Exit;
case cursor.NodeType of
DOCUMENT_NODE:
begin
if reader.XMLVersion <> xmlVersionUnknown then
TXMLDocumentEx(cursor).FXMLVersion := reader.XMLVersion;
TXMLDocumentEx(cursor).FXMLEncoding := reader.XMLEncoding;
end;
ENTITY_NODE:
begin
if reader.XMLVersion <> xmlVersionUnknown then
TDOMEntityEx(cursor).FXMLVersion := reader.XMLVersion;
TDOMEntityEx(cursor).FXMLEncoding := reader.XMLEncoding;
end;
DOCUMENT_NODE, ENTITY_NODE:
(cursor as TDOMNode_TopLevel).SetHeaderData(reader.XMLVersion,reader.XMLEncoding);
end;
end;

64
packages/fcl-xml/tests/testxmlconf.lpi Normal file
View File

@ -0,0 +1,64 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="testxmlconf"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<Units Count="1">
<Unit0>
<Filename Value="testxmlconf.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="testxmlconf"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="testxmlconf"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

31
packages/fcl-xml/tests/testxmlconf.lpr Normal file
View File

@ -0,0 +1,31 @@
program testxmlconf;
uses xmlconf;
begin
With TXMLConfig.Create(Nil) do
try
FileName:='test.xml';
OpenKey('General');
SetValue('one',1);
SetValue('two',2);
SetValue('extra/name','michael');
Flush;
finally
Free;
end;
With TXMLConfig.Create(Nil) do
try
FileName:='test.xml';
OpenKey('General');
If GetValue('one',0)<>1 then
Writeln('One does not match');
If GetValue('two',0)<>2 then
Writeln('Two does not match');
if GetValue('extra/name','')<>'michael' then
Writeln('Name does not match');
finally
Free;
end;
end.