--- Merging r29761 into '.':

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 -

.gitattributes

@@ -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

packages/fcl-xml/src/dom.pp

@@ -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
 // -------------------------------------------------------

packages/fcl-xml/src/xmlconf.pp

@@ -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
+    if (FFileName<>'') then
-    SaveToFile(FFilename)
+      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
+  WriteXMLFile(Doc,S);
-  begin
+  FModified := False;
-    WriteXMLFile(Doc, AFilename);
+end;
-    FModified := False;
+
+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);
+    LoadFromFile(AFilename)
-
+  else if not Assigned(Doc) then
-  if not Assigned(Doc) then
+    begin
+    FFileName:=AFileName;
     Doc := TXMLDocument.Create;
-
-  if not Assigned(Doc.DocumentElement) then
     Doc.AppendChild(Doc.CreateElement(FRootName))
-  else
+    end;
-    if Doc.DocumentElement.NodeName <> FRootName then
-      raise EXMLConfigError.Create(SWrongRootName);
-
 end;
 
 procedure TXMLConfig.SetFilename(const AFilename: String);

packages/fcl-xml/src/xmlread.pp

@@ -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:
+      DOCUMENT_NODE, ENTITY_NODE:
-        begin
+        (cursor as TDOMNode_TopLevel).SetHeaderData(reader.XMLVersion,reader.XMLEncoding);
-          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;
     end;
   end;
 

packages/fcl-xml/tests/testxmlconf.lpi

@@ -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>

packages/fcl-xml/tests/testxmlconf.lpr

@@ -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.
+