mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-09-05 15:40:23 +02:00
added updated xmlreader/writer units
git-svn-id: trunk@25342 -
This commit is contained in:
mattias
parent
ad08a450e3
commit
7d34ac4326
5
.gitattributes
vendored
5
.gitattributes
vendored
@ -567,6 +567,11 @@ components/codetools/languages/codetoolsstrconsts.ru.po svneol=native#text/plain
|
|||||||
components/codetools/languages/codetoolsstrconsts.sk.po svneol=native#text/plain
|
components/codetools/languages/codetoolsstrconsts.sk.po svneol=native#text/plain
|
||||||
components/codetools/languages/codetoolsstrconsts.ua.po svneol=native#text/plain
|
components/codetools/languages/codetoolsstrconsts.ua.po svneol=native#text/plain
|
||||||
components/codetools/languages/codetoolsstrconsts.zh_CN.po svneol=native#text/utf8
|
components/codetools/languages/codetoolsstrconsts.zh_CN.po svneol=native#text/utf8
|
||||||
|
components/codetools/laz2_dom.pas svneol=native#text/plain
|
||||||
|
components/codetools/laz2_names.inc svneol=native#text/plain
|
||||||
|
components/codetools/laz2_xmlread.pas svneol=native#text/plain
|
||||||
|
components/codetools/laz2_xmlutils.pas svneol=native#text/plain
|
||||||
|
components/codetools/laz2_xmlwrite.pas svneol=native#text/plain
|
||||||
components/codetools/laz_dom.pas svneol=native#text/pascal
|
components/codetools/laz_dom.pas svneol=native#text/pascal
|
||||||
components/codetools/laz_xmlcfg.pas svneol=native#text/pascal
|
components/codetools/laz_xmlcfg.pas svneol=native#text/pascal
|
||||||
components/codetools/laz_xmlread.pas svneol=native#text/pascal
|
components/codetools/laz_xmlread.pas svneol=native#text/pascal
|
||||||
|
|||||||
@ -26,7 +26,7 @@
|
|||||||
<License Value="GPL-2
|
<License Value="GPL-2
|
||||||
"/>
|
"/>
|
||||||
<Version Major="1" Release="1"/>
|
<Version Major="1" Release="1"/>
|
||||||
<Files Count="57">
|
<Files Count="61">
|
||||||
<Item1>
|
<Item1>
|
||||||
<Filename Value="Makefile"/>
|
<Filename Value="Makefile"/>
|
||||||
<Type Value="Text"/>
|
<Type Value="Text"/>
|
||||||
@ -256,6 +256,22 @@
|
|||||||
<Filename Value="fpcsrcrules.inc"/>
|
<Filename Value="fpcsrcrules.inc"/>
|
||||||
<Type Value="Include"/>
|
<Type Value="Include"/>
|
||||||
</Item57>
|
</Item57>
|
||||||
|
<Item58>
|
||||||
|
<Filename Value="laz2_xmlutils.pas"/>
|
||||||
|
<UnitName Value="laz2_xmlutils"/>
|
||||||
|
</Item58>
|
||||||
|
<Item59>
|
||||||
|
<Filename Value="laz2_dom.pas"/>
|
||||||
|
<UnitName Value="laz2_DOM"/>
|
||||||
|
</Item59>
|
||||||
|
<Item60>
|
||||||
|
<Filename Value="laz2_xmlwrite.pas"/>
|
||||||
|
<UnitName Value="laz2_XMLWrite"/>
|
||||||
|
</Item60>
|
||||||
|
<Item61>
|
||||||
|
<Filename Value="laz2_xmlread.pas"/>
|
||||||
|
<UnitName Value="laz2_XMLRead"/>
|
||||||
|
</Item61>
|
||||||
</Files>
|
</Files>
|
||||||
<i18n>
|
<i18n>
|
||||||
<EnableI18N Value="True"/>
|
<EnableI18N Value="True"/>
|
||||||
|
|||||||
@ -1,4 +1,4 @@
|
|||||||
{ This file was automatically created by Lazarus. do not edit!
|
{ This file was automatically created by Lazarus. Do not edit!
|
||||||
This source is only used to compile and install the package.
|
This source is only used to compile and install the package.
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -17,8 +17,8 @@ uses
|
|||||||
Laz_XMLStreaming, Laz_XMLWrite, LFMTrees, LinkScanner, MethodJumpTool,
|
Laz_XMLStreaming, Laz_XMLWrite, LFMTrees, LinkScanner, MethodJumpTool,
|
||||||
MultiKeyWordListTool, NonPascalCodeTools, PascalParserTool,
|
MultiKeyWordListTool, NonPascalCodeTools, PascalParserTool,
|
||||||
PascalReaderTool, PPUCodeTools, PPUGraph, PPUParser, ResourceCodeTool,
|
PascalReaderTool, PPUCodeTools, PPUGraph, PPUParser, ResourceCodeTool,
|
||||||
SourceChanger, SourceLog, StdCodeTools, OtherIdentifierTree,
|
SourceChanger, SourceLog, StdCodeTools, OtherIdentifierTree, laz2_xmlutils,
|
||||||
LazarusPackageIntf;
|
laz2_DOM, laz2_XMLWrite, laz2_XMLRead, LazarusPackageIntf;
|
||||||
|
|
||||||
implementation
|
implementation
|
||||||
|
|
||||||
|
|||||||
@ -47,8 +47,13 @@ unit CodeToolsConfig;
|
|||||||
interface
|
interface
|
||||||
|
|
||||||
uses
|
uses
|
||||||
Classes, SysUtils, Laz_XMLCfg, Laz_XMLRead, Laz_XMLWrite, Laz_DOM, FileProcs,
|
Classes, SysUtils, Laz_XMLCfg,
|
||||||
CodeCache, DefineTemplates;
|
{$IFDEF NewXMLCfg}
|
||||||
|
Laz2_XMLRead, Laz2_XMLWrite, Laz2_DOM,
|
||||||
|
{$ELSE}
|
||||||
|
Laz_XMLRead, Laz_XMLWrite, Laz_DOM,
|
||||||
|
{$ENDIF}
|
||||||
|
FileProcs, CodeCache, DefineTemplates;
|
||||||
|
|
||||||
type
|
type
|
||||||
|
|
||||||
@ -400,7 +405,11 @@ begin
|
|||||||
try
|
try
|
||||||
Buf.SaveToStream(ms);
|
Buf.SaveToStream(ms);
|
||||||
ms.Position:=0;
|
ms.Position:=0;
|
||||||
|
{$IFDEF NewXMLCfg}
|
||||||
|
Laz2_XMLRead.ReadXMLFile(ADoc, ms);
|
||||||
Laz_XMLRead.ReadXMLFile(ADoc, ms);
|
Laz_XMLRead.ReadXMLFile(ADoc, ms);
|
||||||
|
{$ELSE}
|
||||||
|
{$ENDIF}
|
||||||
exit; // success
|
exit; // success
|
||||||
finally
|
finally
|
||||||
ms.Free;
|
ms.Free;
|
||||||
@ -429,7 +438,11 @@ begin
|
|||||||
fKeepFileAttributes:=true;
|
fKeepFileAttributes:=true;
|
||||||
ms:=TMemoryStream.Create;
|
ms:=TMemoryStream.Create;
|
||||||
try
|
try
|
||||||
|
{$IFDEF NewXMLCfg}
|
||||||
|
Laz2_XMLWrite.WriteXMLFile(ADoc, ms);
|
||||||
|
{$ELSE}
|
||||||
Laz_XMLWrite.WriteXMLFile(ADoc, ms);
|
Laz_XMLWrite.WriteXMLFile(ADoc, ms);
|
||||||
|
{$ENDIF}
|
||||||
ms.Position:=0;
|
ms.Position:=0;
|
||||||
Buf.LoadFromStream(ms);
|
Buf.LoadFromStream(ms);
|
||||||
if Buf.Save then exit; // success
|
if Buf.Save then exit; // success
|
||||||
|
|||||||
3338
components/codetools/laz2_dom.pas
Normal file
3338
components/codetools/laz2_dom.pas
Normal file
File diff suppressed because it is too large
Load Diff
241
components/codetools/laz2_names.inc
Normal file
241
components/codetools/laz2_names.inc
Normal file
@ -0,0 +1,241 @@
|
|||||||
|
{
|
||||||
|
This file is part of the Free Component Library
|
||||||
|
|
||||||
|
XML naming character tables, built upon w3.org specifications
|
||||||
|
|
||||||
|
See the file COPYING.FPC, 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.
|
||||||
|
|
||||||
|
**********************************************************************}
|
||||||
|
|
||||||
|
type
|
||||||
|
TSetOfByte = set of Byte;
|
||||||
|
|
||||||
|
const
|
||||||
|
// colon ($3a) is excluded, it is handled in the code
|
||||||
|
ns_ASCII = [{ $3A,} $41..$5A, $5F, $61..$7A, $C0..$D6, $D8..$F6, $F8..$FF];
|
||||||
|
ns_0200 = [0..$17, $50..$A8, $BB..$C1];
|
||||||
|
ns_0300 = [$86, $88..$8A, $8C, $8E..$A1,
|
||||||
|
$A3..$CE, $D0..$D6, $DA, $DC,
|
||||||
|
$DE, $E0, $E2..$F3];
|
||||||
|
ns_0400 = [$01..$0C, $0E..$4F, $51..$5C,
|
||||||
|
$5E..$81, $90..$C4, $C7..$C8,
|
||||||
|
$CB..$CC, $D0..$EB, $EE..$F5,
|
||||||
|
$F8..$F9];
|
||||||
|
ns_0500 = [$31..$56, $59, $61..$86, $D0..$EA, $F0..$F2];
|
||||||
|
ns_0600 = [$21..$3A, $41..$4A, $71..$B7,
|
||||||
|
$BA..$BE, $C0..$CE, $D0..$D3,
|
||||||
|
$D5, $E5..$E6];
|
||||||
|
ns_0900 = [$05..$39, $3D, $58..$61,
|
||||||
|
$85..$8C, $8F..$90, $93..$A8,
|
||||||
|
$AA..$B0, $B2, $B6..$B9,
|
||||||
|
$DC..$DD, $DF..$E1, $F0..$F1];
|
||||||
|
ns_0A00 = [$05..$0A, $0F..$10, $13..$28,
|
||||||
|
$2A..$30, $32..$33, $35..$36,
|
||||||
|
$38..$39, $59..$5C, $5E, $72..$74,
|
||||||
|
$85..$8B, $8D, $8F..$91, $93..$A8,
|
||||||
|
$AA..$B0, $B2..$B3, $B5..$B9, $BD, $E0];
|
||||||
|
ns_0B00 = [$05..$0C, $0F..$10, $13..$28,
|
||||||
|
$2A..$30, $32..$33, $36..$39,
|
||||||
|
$3D, $5C..$5D, $5F..$61, $85..$8A,
|
||||||
|
$8E..$90, $92..$95, $99..$9A,
|
||||||
|
$9C, $9E..$9F, $A3..$A4, $A8..$AA,
|
||||||
|
$AE..$B5, $B7..$B9];
|
||||||
|
ns_0C00 = [$05..$0C, $0E..$10, $12..$28,
|
||||||
|
$2A..$33, $35..$39, $60..$61,
|
||||||
|
$85..$8C, $8E..$90, $92..$A8,
|
||||||
|
$AA..$B3, $B5..$B9, $DE, $E0..$E1];
|
||||||
|
ns_0D00 = [$05..$0C, $0E..$10, $12..$28, $2A..$39, $60..$61];
|
||||||
|
ns_0E00 = [$01..$2E, $30, $32..$33, $40..$45,
|
||||||
|
$81..$82, $84, $87..$88, $8A, $8D,
|
||||||
|
$94..$97, $99..$9F, $A1..$A3,
|
||||||
|
$A5, $A7, $AA..$AB, $AD..$AE,
|
||||||
|
$B0, $B2..$B3, $BD, $C0..$C4];
|
||||||
|
ns_0F00 = [$40..$47, $49..$69];
|
||||||
|
|
||||||
|
ns_3000 = [$41..$94, $A1..$FA] + [$07, $21..$29];
|
||||||
|
|
||||||
|
namingBitmap: array[0..$30] of TSetOfByte = (
|
||||||
|
|
||||||
|
[], // 00 - nothing allowed
|
||||||
|
[0..255], // 01 - all allowed
|
||||||
|
ns_ASCII, // 02
|
||||||
|
[0..$31, $34..$3E, $41..$48, // 03 - $0100, both Name and NameStart
|
||||||
|
$4A..$7E, $80..$C3, $CD..$F0,
|
||||||
|
$F4..$F5, $FA..$FF],
|
||||||
|
|
||||||
|
ns_0200, // 04
|
||||||
|
ns_0300, // 05
|
||||||
|
ns_0400, // 06
|
||||||
|
ns_0500, // 07
|
||||||
|
ns_0600, // 08
|
||||||
|
ns_0900, // 09
|
||||||
|
ns_0A00, // 0A
|
||||||
|
ns_0B00, // 0B
|
||||||
|
ns_0C00, // 0C
|
||||||
|
ns_0D00, // 0D
|
||||||
|
ns_0E00, // 0E
|
||||||
|
ns_0F00, // 0F
|
||||||
|
[$A0..$C5, $D0..$F6], // 10 - $1000, both Name and NameStart
|
||||||
|
[0, $02..03, $05..$07, $09, // 11 - $1100, both Name and NameStart
|
||||||
|
$0B..$0C, $0E..$12, $3C, $3E,
|
||||||
|
$40, $4C, $4E, $50, $54..$55,
|
||||||
|
$59, $5F..$61, $63, $65, $67,
|
||||||
|
$69, $6D..$6E, $72..$73, $75,
|
||||||
|
$9E, $A8, $AB, $AE..$AF,
|
||||||
|
$B7..$B8, $BA, $BC..$C2, $EB, $F0, $F9],
|
||||||
|
[0..$9B, $A0..$F9], // 12 - $1E00, both Name and NameStart
|
||||||
|
[0..$15, $18..$1D, $20..$45, // 13 - $1F00, both Name and NameStart
|
||||||
|
$48..$4D, $50..$57, $59, $5B, $5D,
|
||||||
|
$5F..$7D, $80..$B4, $B6..$BC, $BE,
|
||||||
|
$C2..$C4, $C6..$CC, $D0..$D3,
|
||||||
|
$D6..$DB, $E0..$EC, $F2..$F4, $F6..$FC],
|
||||||
|
[$26, $2A..$2B, $2E, $80..$82], // 14 - $2100, NameStart
|
||||||
|
ns_3000, // 15
|
||||||
|
[$05..$2C], // 16 - $3100, NameStart
|
||||||
|
[0..$A5], // 17 - $9F00, NameStart (ideographs)
|
||||||
|
[0..$A3], // 18 - $D700, NameStart
|
||||||
|
|
||||||
|
ns_ASCII + // 19 - $0000, Names
|
||||||
|
[$2D..$2E, $30..$39, $B7],
|
||||||
|
ns_0200 + // 1A - $0200, Names
|
||||||
|
[$D0..$D1],
|
||||||
|
ns_0300 + // 1B - $0300, Names
|
||||||
|
[0..$45, $60..$61, $87],
|
||||||
|
ns_0400 + // 1C - $0400, Names
|
||||||
|
[$83..$86],
|
||||||
|
ns_0500 + // 1D - $0500, Names
|
||||||
|
[$91..$A1, $A3..$B9, $BB..$BD, { combining }
|
||||||
|
$BF, $C1..$C2, $C4],
|
||||||
|
ns_0600 + // 1E - $0600, Names
|
||||||
|
[$4B..$52, $70, $D6..$DC, $DD..$DF, { combining }
|
||||||
|
$E0..$E4, $E7..$E8, $EA..$ED] +
|
||||||
|
[$60..$69, $F0..$F9] + [$40], { digits + ext }
|
||||||
|
ns_0900 + // 1F - $0900, Names
|
||||||
|
[$01..$03, $3C, $3E..$4C, $4D, { combining }
|
||||||
|
$51..$54, $62..$63, $81..$83,
|
||||||
|
$BC, $BE, $BF, $C0..$C4, $C7..$C8,
|
||||||
|
$CB..$CD, $D7, $E2..$E3] +
|
||||||
|
[$66..$6F, $E6..$EF], { digits }
|
||||||
|
ns_0A00 + // 20 - $0A00, Names
|
||||||
|
[$02, $3C, $3E..$42, $47..$48, $4B..$4D, { combining }
|
||||||
|
$70..$71, $81..$83, $BC, $BE..$C5,
|
||||||
|
$C7..$C9, $CB..$CD] +
|
||||||
|
[$66..$6F, $E6..$EF], { digits }
|
||||||
|
ns_0B00 + // 21 - $0B00, Names
|
||||||
|
[$01..$03, $3C, $3E..$43, $47..$48, { combining }
|
||||||
|
$4B..$4D, $56..$57, $82..$83, $BE..$C2,
|
||||||
|
$C6..$C8, $CA..$CD, $D7] +
|
||||||
|
[$66..$6F, $E7..$EF], { digits }
|
||||||
|
ns_0C00 + // 22 - $0C00, Names
|
||||||
|
[$01..$03, $3E..$44, $46..$48, { combining }
|
||||||
|
$4A..$4D, $55..$56, $82..$83,
|
||||||
|
$BE..$C4, $C6..$C8, $CA..$CD, $D5..$D6] +
|
||||||
|
[$66..$6F, $E6..$EF], { digits }
|
||||||
|
ns_0D00 + // 23 - $0D00, Names
|
||||||
|
[$02..$03, $3E..$43, { combining }
|
||||||
|
$46..$48, $4A..$4D, $57] +
|
||||||
|
[$66..$6F], { digits }
|
||||||
|
ns_0E00 + // 24 - $0E00, Names
|
||||||
|
[$31, $34..$3A, $47..$4E, { combining }
|
||||||
|
$B1, $B4..$B9, $BB..$BC,
|
||||||
|
$C8..$CD] +
|
||||||
|
[$50..$59, $D0..$D9] + { digits }
|
||||||
|
[$46, $C6], { extenders }
|
||||||
|
ns_0F00 + // 25 - $0F00, Names
|
||||||
|
[$18..$19, $35, $37, $39, { combining }
|
||||||
|
$3E, $3F, $71..$84, $86..$8B,
|
||||||
|
$90..$95, $97, $99..$AD,
|
||||||
|
$B1..$B7, $B9] +
|
||||||
|
[$20..$29], { digits }
|
||||||
|
[$D0..$DC, $E1], // 26 - $2000, Names (combining)
|
||||||
|
ns_3000 + // 27 - $3000, Names
|
||||||
|
[$2A..$2F, $99, $9A] + { combining }
|
||||||
|
[$05, $31..$35, $9D..$9E, $FC..$FE], { extenders }
|
||||||
|
|
||||||
|
{ XML 1.1 additions }
|
||||||
|
|
||||||
|
[0..$CF, $F0..$FF], // 28 $FD00 - NameStart
|
||||||
|
[0..$EF], // 29 $2F00 - NameStart
|
||||||
|
[$0C..$0D, $70..$FF], // 2A $2000 - NameStart
|
||||||
|
[0..$8F], // 2B $2100 - NameStart
|
||||||
|
[$70..$7D, $7F..$FF], // 2C $0300 - NameStart
|
||||||
|
[1..$FF], // 2D $3000 - NameStart
|
||||||
|
[0..$7D, $7F..$FF], // 2E $0300 - Names
|
||||||
|
[$0C..$0D, $3F..$40, $70..$FF], // 2F $2000 - Names
|
||||||
|
[$00..$FD] // 30 $FF00 - both Name and NameStart
|
||||||
|
);
|
||||||
|
|
||||||
|
Xml11HighPages: TSetOfByte = [0..$21, $2C..$D7, $F9..$FE];
|
||||||
|
|
||||||
|
NamePages: array[0..511] of Byte = (
|
||||||
|
$02, $03, $04, $05, $06, $07, $08, $00,
|
||||||
|
$00, $09, $0A, $0B, $0C, $0D, $0E, $0F,
|
||||||
|
$10, $11, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $12, $13,
|
||||||
|
$00, $14, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
$15, $16, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $17,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $18,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
// second half - NameChars
|
||||||
|
$19, $03, $1A, $1B, $1C, $1D, $1E, $00,
|
||||||
|
$00, $1F, $20, $21, $22, $23, $24, $25,
|
||||||
|
$10, $11, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $12, $13,
|
||||||
|
$26, $14, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
$27, $16, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $17,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $01,
|
||||||
|
$01, $01, $01, $01, $01, $01, $01, $18,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00,
|
||||||
|
$00, $00, $00, $00, $00, $00, $00, $00);
|
||||||
|
|
||||||
4121
components/codetools/laz2_xmlread.pas
Normal file
4121
components/codetools/laz2_xmlread.pas
Normal file
File diff suppressed because it is too large
Load Diff
846
components/codetools/laz2_xmlutils.pas
Normal file
846
components/codetools/laz2_xmlutils.pas
Normal file
@ -0,0 +1,846 @@
|
|||||||
|
{
|
||||||
|
This file is part of the Free Component Library
|
||||||
|
|
||||||
|
XML utility routines.
|
||||||
|
Copyright (c) 2006 by Sergei Gorelkin, sergei_gorelkin@mail.ru
|
||||||
|
|
||||||
|
See the file COPYING.FPC, 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 laz2_xmlutils;
|
||||||
|
|
||||||
|
{$ifdef fpc}{$mode objfpc}{$endif}
|
||||||
|
{$H+}
|
||||||
|
{$ifopt Q+}{$define overflow_check}{$endif}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
SysUtils, Classes;
|
||||||
|
|
||||||
|
type
|
||||||
|
TXMLUtilString = AnsiString;
|
||||||
|
TXMLUtilChar = Char;
|
||||||
|
PXMLUtilChar = PChar;
|
||||||
|
PXMLUtilString = ^TXMLUtilString;
|
||||||
|
|
||||||
|
function IsXmlName(const Value: TXMLUtilString; Xml11: Boolean = False): Boolean; overload;
|
||||||
|
function IsXmlName(Value: PXMLUtilChar; Len: Integer; Xml11: Boolean = False): Boolean; overload;
|
||||||
|
function IsXmlNames(const Value: TXMLUtilString; Xml11: Boolean = False): Boolean;
|
||||||
|
function IsXmlNmToken(const Value: TXMLUtilString; Xml11: Boolean = False): Boolean;
|
||||||
|
function IsXmlNmTokens(const Value: TXMLUtilString; Xml11: Boolean = False): Boolean;
|
||||||
|
function IsValidXmlEncoding(const Value: TXMLUtilString): Boolean;
|
||||||
|
function Xml11NamePages: PByteArray;
|
||||||
|
procedure NormalizeSpaces(var Value: TXMLUtilString);
|
||||||
|
function IsXmlWhiteSpace(c: PXMLUtilChar): Boolean;
|
||||||
|
function Hash(InitValue: LongWord; Key: PXMLUtilChar; KeyLen: Integer): LongWord;
|
||||||
|
{ beware, works in ASCII range only }
|
||||||
|
function WStrLIComp(S1, S2: PXMLUtilChar; Len: Integer): Integer;
|
||||||
|
|
||||||
|
{ a simple hash table with TXMLUtilString keys }
|
||||||
|
|
||||||
|
type
|
||||||
|
{$ifndef fpc}
|
||||||
|
PtrInt = LongInt;
|
||||||
|
TFPList = TList;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
PPHashItem = ^PHashItem;
|
||||||
|
PHashItem = ^THashItem;
|
||||||
|
THashItem = record
|
||||||
|
Key: TXMLUtilString;
|
||||||
|
HashValue: LongWord;
|
||||||
|
Next: PHashItem;
|
||||||
|
Data: TObject;
|
||||||
|
end;
|
||||||
|
THashItemArray = array[0..MaxInt div sizeof(Pointer)-1] of PHashItem;
|
||||||
|
PHashItemArray = ^THashItemArray;
|
||||||
|
|
||||||
|
THashForEach = function(Entry: PHashItem; arg: Pointer): Boolean;
|
||||||
|
|
||||||
|
THashTable = class(TObject)
|
||||||
|
private
|
||||||
|
FCount: LongWord;
|
||||||
|
FBucketCount: LongWord;
|
||||||
|
FBucket: PHashItemArray;
|
||||||
|
FOwnsObjects: Boolean;
|
||||||
|
function Lookup(Key: PXMLUtilChar; KeyLength: Integer; out Found: Boolean; CanCreate: Boolean): PHashItem;
|
||||||
|
procedure Resize(NewCapacity: LongWord);
|
||||||
|
public
|
||||||
|
constructor Create(InitSize: Integer; OwnObjects: Boolean);
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure Clear;
|
||||||
|
function Find(Key: PXMLUtilChar; KeyLen: Integer): PHashItem;
|
||||||
|
function FindOrAdd(Key: PXMLUtilChar; KeyLen: Integer; var Found: Boolean): PHashItem; overload;
|
||||||
|
function FindOrAdd(Key: PXMLUtilChar; KeyLen: Integer): PHashItem; overload;
|
||||||
|
function Get(Key: PXMLUtilChar; KeyLen: Integer): TObject;
|
||||||
|
function Remove(Entry: PHashItem): Boolean;
|
||||||
|
function RemoveData(aData: TObject): Boolean;
|
||||||
|
procedure ForEach(proc: THashForEach; arg: Pointer);
|
||||||
|
property Count: LongWord read FCount;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ another hash, for detecting duplicate namespaced attributes without memory allocations }
|
||||||
|
|
||||||
|
TExpHashEntry = record
|
||||||
|
rev: LongWord;
|
||||||
|
hash: LongWord;
|
||||||
|
uriPtr: PXMLUtilString;
|
||||||
|
lname: PXMLUtilChar;
|
||||||
|
lnameLen: Integer;
|
||||||
|
end;
|
||||||
|
TExpHashEntryArray = array[0..MaxInt div sizeof(TExpHashEntry)-1] of TExpHashEntry;
|
||||||
|
PExpHashEntryArray = ^TExpHashEntryArray;
|
||||||
|
|
||||||
|
TDblHashArray = class(TObject)
|
||||||
|
private
|
||||||
|
FSizeLog: Integer;
|
||||||
|
FRevision: LongWord;
|
||||||
|
FData: PExpHashEntryArray;
|
||||||
|
public
|
||||||
|
procedure Init(NumSlots: Integer);
|
||||||
|
function Locate(uri: PXMLUtilString; localName: PXMLUtilChar; localLength: Integer): Boolean;
|
||||||
|
destructor Destroy; override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TBinding = class
|
||||||
|
public
|
||||||
|
uri: TXMLUtilString;
|
||||||
|
next: TBinding;
|
||||||
|
prevPrefixBinding: TObject;
|
||||||
|
Prefix: PHashItem;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TAttributeAction = (
|
||||||
|
aaUnchanged,
|
||||||
|
aaPrefix, // only override the prefix
|
||||||
|
aaBoth // override prefix and emit namespace definition
|
||||||
|
);
|
||||||
|
|
||||||
|
TNSSupport = class(TObject)
|
||||||
|
private
|
||||||
|
FNesting: Integer;
|
||||||
|
FPrefixSeqNo: Integer;
|
||||||
|
FFreeBindings: TBinding;
|
||||||
|
FBindings: TFPList;
|
||||||
|
FBindingStack: array of TBinding;
|
||||||
|
FPrefixes: THashTable;
|
||||||
|
FDefaultPrefix: THashItem;
|
||||||
|
public
|
||||||
|
constructor Create;
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure DefineBinding(const Prefix, nsURI: TXMLUtilString; out Binding: TBinding);
|
||||||
|
function CheckAttribute(const Prefix, nsURI: TXMLUtilString;
|
||||||
|
out Binding: TBinding): TAttributeAction;
|
||||||
|
function IsPrefixBound(P: PXMLUtilChar; Len: Integer; out Prefix: PHashItem): Boolean;
|
||||||
|
function GetPrefix(P: PXMLUtilChar; Len: Integer): PHashItem;
|
||||||
|
function BindPrefix(const nsURI: TXMLUtilString; aPrefix: PHashItem): TBinding;
|
||||||
|
function DefaultNSBinding: TBinding;
|
||||||
|
procedure StartElement;
|
||||||
|
procedure EndElement;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$i laz2_names.inc}
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
var
|
||||||
|
Xml11Pg: PByteArray = nil;
|
||||||
|
|
||||||
|
function Xml11NamePages: PByteArray;
|
||||||
|
var
|
||||||
|
I: Integer;
|
||||||
|
p: PByteArray;
|
||||||
|
begin
|
||||||
|
if Xml11Pg = nil then
|
||||||
|
begin
|
||||||
|
GetMem(p, 512);
|
||||||
|
for I := 0 to 255 do
|
||||||
|
p^[I] := ord(Byte(I) in Xml11HighPages);
|
||||||
|
p^[0] := 2;
|
||||||
|
p^[3] := $2c;
|
||||||
|
p^[$20] := $2a;
|
||||||
|
p^[$21] := $2b;
|
||||||
|
p^[$2f] := $29;
|
||||||
|
p^[$30] := $2d;
|
||||||
|
p^[$fd] := $28;
|
||||||
|
p^[$ff] := $30;
|
||||||
|
|
||||||
|
Move(p^, p^[256], 256);
|
||||||
|
p^[$100] := $19;
|
||||||
|
p^[$103] := $2E;
|
||||||
|
p^[$120] := $2F;
|
||||||
|
Xml11Pg := p;
|
||||||
|
end;
|
||||||
|
Result := Xml11Pg;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function IsXml11Char(Value: PXMLUtilChar; var Index: Integer): Boolean; overload;
|
||||||
|
begin
|
||||||
|
if (Value[Index] >= #$D800) and (Value[Index] <= #$DB7F) then
|
||||||
|
begin
|
||||||
|
Inc(Index);
|
||||||
|
Result := (Value[Index] >= #$DC00) and (Value[Index] <= #$DFFF);
|
||||||
|
end
|
||||||
|
else
|
||||||
|
Result := False;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function IsXml11Char(const Value: TXMLUtilString; var Index: Integer): Boolean; overload;
|
||||||
|
begin
|
||||||
|
if (Value[Index] >= #$D800) and (Value[Index] <= #$DB7F) then
|
||||||
|
begin
|
||||||
|
Inc(Index);
|
||||||
|
Result := (Value[Index] >= #$DC00) and (Value[Index] <= #$DFFF);
|
||||||
|
end
|
||||||
|
else
|
||||||
|
Result := False;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function IsXmlName(const Value: TXMLUtilString; Xml11: Boolean): Boolean;
|
||||||
|
begin
|
||||||
|
Result := IsXmlName(PXMLUtilChar(Value), Length(Value), Xml11);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function IsXmlName(Value: PXMLUtilChar; Len: Integer; Xml11: Boolean = False): Boolean;
|
||||||
|
var
|
||||||
|
Pages: PByteArray;
|
||||||
|
I: Integer;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
if Xml11 then
|
||||||
|
Pages := Xml11NamePages
|
||||||
|
else
|
||||||
|
Pages := @NamePages;
|
||||||
|
|
||||||
|
I := 0;
|
||||||
|
if (Len = 0) or not ((Byte(Value[I]) in NamingBitmap[Pages^[hi(Word(Value[I]))]]) or
|
||||||
|
(Value[I] = ':') or
|
||||||
|
(Xml11 and IsXml11Char(Value, I))) then
|
||||||
|
Exit;
|
||||||
|
Inc(I);
|
||||||
|
while I < Len do
|
||||||
|
begin
|
||||||
|
if not ((Byte(Value[I]) in NamingBitmap[Pages^[$100+hi(Word(Value[I]))]]) or
|
||||||
|
(Value[I] = ':') or
|
||||||
|
(Xml11 and IsXml11Char(Value, I))) then
|
||||||
|
Exit;
|
||||||
|
Inc(I);
|
||||||
|
end;
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function IsXmlNames(const Value: TXMLUtilString; Xml11: Boolean): Boolean;
|
||||||
|
var
|
||||||
|
Pages: PByteArray;
|
||||||
|
I: Integer;
|
||||||
|
Offset: Integer;
|
||||||
|
begin
|
||||||
|
if Xml11 then
|
||||||
|
Pages := Xml11NamePages
|
||||||
|
else
|
||||||
|
Pages := @NamePages;
|
||||||
|
Result := False;
|
||||||
|
if Value = '' then
|
||||||
|
Exit;
|
||||||
|
I := 1;
|
||||||
|
Offset := 0;
|
||||||
|
while I <= Length(Value) do
|
||||||
|
begin
|
||||||
|
if not ((Byte(Value[I]) in NamingBitmap[Pages^[Offset+hi(Word(Value[I]))]]) or
|
||||||
|
(Value[I] = ':') or
|
||||||
|
(Xml11 and IsXml11Char(Value, I))) then
|
||||||
|
begin
|
||||||
|
if (I = Length(Value)) or (Value[I] <> #32) then
|
||||||
|
Exit;
|
||||||
|
Offset := 0;
|
||||||
|
Inc(I);
|
||||||
|
Continue;
|
||||||
|
end;
|
||||||
|
Offset := $100;
|
||||||
|
Inc(I);
|
||||||
|
end;
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function IsXmlNmToken(const Value: TXMLUtilString; Xml11: Boolean): Boolean;
|
||||||
|
var
|
||||||
|
I: Integer;
|
||||||
|
Pages: PByteArray;
|
||||||
|
begin
|
||||||
|
if Xml11 then
|
||||||
|
Pages := Xml11NamePages
|
||||||
|
else
|
||||||
|
Pages := @NamePages;
|
||||||
|
Result := False;
|
||||||
|
if Value = '' then
|
||||||
|
Exit;
|
||||||
|
I := 1;
|
||||||
|
while I <= Length(Value) do
|
||||||
|
begin
|
||||||
|
if not ((Byte(Value[I]) in NamingBitmap[Pages^[$100+hi(Word(Value[I]))]]) or
|
||||||
|
(Value[I] = ':') or
|
||||||
|
(Xml11 and IsXml11Char(Value, I))) then
|
||||||
|
Exit;
|
||||||
|
Inc(I);
|
||||||
|
end;
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function IsXmlNmTokens(const Value: TXMLUtilString; Xml11: Boolean): Boolean;
|
||||||
|
var
|
||||||
|
I: Integer;
|
||||||
|
Pages: PByteArray;
|
||||||
|
begin
|
||||||
|
if Xml11 then
|
||||||
|
Pages := Xml11NamePages
|
||||||
|
else
|
||||||
|
Pages := @NamePages;
|
||||||
|
I := 1;
|
||||||
|
Result := False;
|
||||||
|
if Value = '' then
|
||||||
|
Exit;
|
||||||
|
while I <= Length(Value) do
|
||||||
|
begin
|
||||||
|
if not ((Byte(Value[I]) in NamingBitmap[Pages^[$100+hi(Word(Value[I]))]]) or
|
||||||
|
(Value[I] = ':') or
|
||||||
|
(Xml11 and IsXml11Char(Value, I))) then
|
||||||
|
begin
|
||||||
|
if (I = Length(Value)) or (Value[I] <> #32) then
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
Inc(I);
|
||||||
|
end;
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function IsValidXmlEncoding(const Value: TXMLUtilString): Boolean;
|
||||||
|
var
|
||||||
|
I: Integer;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
if (Value = '') or (Value[1] > #255) or not (char(ord(Value[1])) in ['A'..'Z', 'a'..'z']) then
|
||||||
|
Exit;
|
||||||
|
for I := 2 to Length(Value) do
|
||||||
|
if (Value[I] > #255) or not (char(ord(Value[I])) in ['A'..'Z', 'a'..'z', '0'..'9', '.', '_', '-']) then
|
||||||
|
Exit;
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure NormalizeSpaces(var Value: TXMLUtilString);
|
||||||
|
var
|
||||||
|
I, J: Integer;
|
||||||
|
begin
|
||||||
|
I := Length(Value);
|
||||||
|
// speed: trim only whed needed
|
||||||
|
if (I > 0) and ((Value[1] = #32) or (Value[I] = #32)) then
|
||||||
|
Value := Trim(Value);
|
||||||
|
I := 1;
|
||||||
|
while I < Length(Value) do
|
||||||
|
begin
|
||||||
|
if Value[I] = #32 then
|
||||||
|
begin
|
||||||
|
J := I+1;
|
||||||
|
while (J <= Length(Value)) and (Value[J] = #32) do Inc(J);
|
||||||
|
if J-I > 1 then Delete(Value, I+1, J-I-1);
|
||||||
|
end;
|
||||||
|
Inc(I);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function IsXmlWhiteSpace(c: PXMLUtilChar): Boolean;
|
||||||
|
begin
|
||||||
|
Result := c^ in [#32,#9,#10,#13];
|
||||||
|
end;
|
||||||
|
|
||||||
|
function WStrLIComp(S1, S2: PXMLUtilChar; Len: Integer): Integer;
|
||||||
|
var
|
||||||
|
counter: Integer;
|
||||||
|
c1, c2: Word;
|
||||||
|
begin
|
||||||
|
counter := 0;
|
||||||
|
result := 0;
|
||||||
|
if Len = 0 then
|
||||||
|
exit;
|
||||||
|
repeat
|
||||||
|
c1 := ord(S1[counter]);
|
||||||
|
c2 := ord(S2[counter]);
|
||||||
|
if (c1 = 0) or (c2 = 0) then break;
|
||||||
|
if c1 <> c2 then
|
||||||
|
begin
|
||||||
|
if c1 in [97..122] then
|
||||||
|
Dec(c1, 32);
|
||||||
|
if c2 in [97..122] then
|
||||||
|
Dec(c2, 32);
|
||||||
|
if c1 <> c2 then
|
||||||
|
Break;
|
||||||
|
end;
|
||||||
|
Inc(counter);
|
||||||
|
until counter >= Len;
|
||||||
|
result := c1 - c2;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function Hash(InitValue: LongWord; Key: PXMLUtilChar; KeyLen: Integer): LongWord;
|
||||||
|
begin
|
||||||
|
Result := InitValue;
|
||||||
|
while KeyLen <> 0 do
|
||||||
|
begin
|
||||||
|
{$ifdef overflow_check}{$q-}{$endif}
|
||||||
|
Result := Result * $F4243 xor ord(Key^);
|
||||||
|
{$ifdef overflow_check}{$q+}{$endif}
|
||||||
|
Inc(Key);
|
||||||
|
Dec(KeyLen);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function KeyCompare(const Key1: TXMLUtilString; Key2: Pointer; Key2Len: Integer): Boolean;
|
||||||
|
begin
|
||||||
|
{$IFDEF FPC}
|
||||||
|
Result := (Length(Key1)=Key2Len) and (CompareWord(Pointer(Key1)^, Key2^, Key2Len) = 0);
|
||||||
|
{$ELSE}
|
||||||
|
Result := (Length(Key1)=Key2Len) and CompareMem(Pointer(Key1), Key2, Key2Len*2);
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ THashTable }
|
||||||
|
|
||||||
|
constructor THashTable.Create(InitSize: Integer; OwnObjects: Boolean);
|
||||||
|
var
|
||||||
|
I: Integer;
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
FOwnsObjects := OwnObjects;
|
||||||
|
I := 256;
|
||||||
|
while I < InitSize do I := I shl 1;
|
||||||
|
FBucketCount := I;
|
||||||
|
FBucket := AllocMem(I * sizeof(PHashItem));
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor THashTable.Destroy;
|
||||||
|
begin
|
||||||
|
Clear;
|
||||||
|
FreeMem(FBucket);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure THashTable.Clear;
|
||||||
|
var
|
||||||
|
I: Integer;
|
||||||
|
item, next: PHashItem;
|
||||||
|
begin
|
||||||
|
for I := 0 to FBucketCount-1 do
|
||||||
|
begin
|
||||||
|
item := FBucket^[I];
|
||||||
|
while Assigned(item) do
|
||||||
|
begin
|
||||||
|
next := item^.Next;
|
||||||
|
if FOwnsObjects then
|
||||||
|
item^.Data.Free;
|
||||||
|
Dispose(item);
|
||||||
|
item := next;
|
||||||
|
end;
|
||||||
|
FBucket^[I] := nil;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function THashTable.Find(Key: PXMLUtilChar; KeyLen: Integer): PHashItem;
|
||||||
|
var
|
||||||
|
Dummy: Boolean;
|
||||||
|
begin
|
||||||
|
Result := Lookup(Key, KeyLen, Dummy, False);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function THashTable.FindOrAdd(Key: PXMLUtilChar; KeyLen: Integer;
|
||||||
|
var Found: Boolean): PHashItem;
|
||||||
|
begin
|
||||||
|
Result := Lookup(Key, KeyLen, Found, True);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function THashTable.FindOrAdd(Key: PXMLUtilChar; KeyLen: Integer): PHashItem;
|
||||||
|
var
|
||||||
|
Dummy: Boolean;
|
||||||
|
begin
|
||||||
|
Result := Lookup(Key, KeyLen, Dummy, True);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function THashTable.Get(Key: PXMLUtilChar; KeyLen: Integer): TObject;
|
||||||
|
var
|
||||||
|
e: PHashItem;
|
||||||
|
Dummy: Boolean;
|
||||||
|
begin
|
||||||
|
e := Lookup(Key, KeyLen, Dummy, False);
|
||||||
|
if Assigned(e) then
|
||||||
|
Result := e^.Data
|
||||||
|
else
|
||||||
|
Result := nil;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function THashTable.Lookup(Key: PXMLUtilChar; KeyLength: Integer;
|
||||||
|
out Found: Boolean; CanCreate: Boolean): PHashItem;
|
||||||
|
var
|
||||||
|
Entry: PPHashItem;
|
||||||
|
h: LongWord;
|
||||||
|
begin
|
||||||
|
h := Hash(0, Key, KeyLength);
|
||||||
|
Entry := @FBucket^[h mod FBucketCount];
|
||||||
|
while Assigned(Entry^) and not ((Entry^^.HashValue = h) and KeyCompare(Entry^^.Key, Key, KeyLength) ) do
|
||||||
|
Entry := @Entry^^.Next;
|
||||||
|
Found := Assigned(Entry^);
|
||||||
|
if Found or (not CanCreate) then
|
||||||
|
begin
|
||||||
|
Result := Entry^;
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
if FCount > FBucketCount then { arbitrary limit, probably too high }
|
||||||
|
begin
|
||||||
|
Resize(FBucketCount * 2);
|
||||||
|
Result := Lookup(Key, KeyLength, Found, CanCreate);
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
New(Result);
|
||||||
|
// SetString for TXMLUtilStrings trims on zero chars [fixed, #14740]
|
||||||
|
SetLength(Result^.Key, KeyLength);
|
||||||
|
Move(Key^, Pointer(Result^.Key)^, KeyLength*sizeof(TXMLUtilChar));
|
||||||
|
Result^.HashValue := h;
|
||||||
|
Result^.Data := nil;
|
||||||
|
Result^.Next := nil;
|
||||||
|
Inc(FCount);
|
||||||
|
Entry^ := Result;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure THashTable.Resize(NewCapacity: LongWord);
|
||||||
|
var
|
||||||
|
p: PHashItemArray;
|
||||||
|
chain: PPHashItem;
|
||||||
|
i: Integer;
|
||||||
|
e, n: PHashItem;
|
||||||
|
begin
|
||||||
|
p := AllocMem(NewCapacity * sizeof(PHashItem));
|
||||||
|
for i := 0 to FBucketCount-1 do
|
||||||
|
begin
|
||||||
|
e := FBucket^[i];
|
||||||
|
while Assigned(e) do
|
||||||
|
begin
|
||||||
|
chain := @p^[e^.HashValue mod NewCapacity];
|
||||||
|
n := e^.Next;
|
||||||
|
e^.Next := chain^;
|
||||||
|
chain^ := e;
|
||||||
|
e := n;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
FBucketCount := NewCapacity;
|
||||||
|
FreeMem(FBucket);
|
||||||
|
FBucket := p;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function THashTable.Remove(Entry: PHashItem): Boolean;
|
||||||
|
var
|
||||||
|
chain: PPHashItem;
|
||||||
|
begin
|
||||||
|
chain := @FBucket^[Entry^.HashValue mod FBucketCount];
|
||||||
|
while Assigned(chain^) do
|
||||||
|
begin
|
||||||
|
if chain^ = Entry then
|
||||||
|
begin
|
||||||
|
chain^ := Entry^.Next;
|
||||||
|
if FOwnsObjects then
|
||||||
|
Entry^.Data.Free;
|
||||||
|
Dispose(Entry);
|
||||||
|
Dec(FCount);
|
||||||
|
Result := True;
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
chain := @chain^^.Next;
|
||||||
|
end;
|
||||||
|
Result := False;
|
||||||
|
end;
|
||||||
|
|
||||||
|
// this does not free the aData object
|
||||||
|
function THashTable.RemoveData(aData: TObject): Boolean;
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
|
chain: PPHashItem;
|
||||||
|
e: PHashItem;
|
||||||
|
begin
|
||||||
|
for i := 0 to FBucketCount-1 do
|
||||||
|
begin
|
||||||
|
chain := @FBucket^[i];
|
||||||
|
while Assigned(chain^) do
|
||||||
|
begin
|
||||||
|
if chain^^.Data = aData then
|
||||||
|
begin
|
||||||
|
e := chain^;
|
||||||
|
chain^ := e^.Next;
|
||||||
|
Dispose(e);
|
||||||
|
Dec(FCount);
|
||||||
|
Result := True;
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
chain := @chain^^.Next;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
Result := False;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure THashTable.ForEach(proc: THashForEach; arg: Pointer);
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
|
e: PHashItem;
|
||||||
|
begin
|
||||||
|
for i := 0 to FBucketCount-1 do
|
||||||
|
begin
|
||||||
|
e := FBucket^[i];
|
||||||
|
while Assigned(e) do
|
||||||
|
begin
|
||||||
|
if not proc(e, arg) then
|
||||||
|
Exit;
|
||||||
|
e := e^.Next;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TDblHashArray }
|
||||||
|
|
||||||
|
destructor TDblHashArray.Destroy;
|
||||||
|
begin
|
||||||
|
FreeMem(FData);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TDblHashArray.Init(NumSlots: Integer);
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
|
begin
|
||||||
|
if ((NumSlots * 2) shr FSizeLog) <> 0 then // need at least twice more entries, and no less than 8
|
||||||
|
begin
|
||||||
|
FSizeLog := 3;
|
||||||
|
while (NumSlots shr FSizeLog) <> 0 do
|
||||||
|
Inc(FSizeLog);
|
||||||
|
ReallocMem(FData, (1 shl FSizeLog) * sizeof(TExpHashEntry));
|
||||||
|
FRevision := 0;
|
||||||
|
end;
|
||||||
|
if FRevision = 0 then
|
||||||
|
begin
|
||||||
|
FRevision := $FFFFFFFF;
|
||||||
|
for i := (1 shl FSizeLog)-1 downto 0 do
|
||||||
|
FData^[i].rev := FRevision;
|
||||||
|
end;
|
||||||
|
Dec(FRevision);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TDblHashArray.Locate(uri: PXMLUtilString; localName: PXMLUtilChar; localLength: Integer): Boolean;
|
||||||
|
var
|
||||||
|
step: Byte;
|
||||||
|
mask: LongWord;
|
||||||
|
idx: Integer;
|
||||||
|
HashValue: LongWord;
|
||||||
|
begin
|
||||||
|
HashValue := Hash(0, PXMLUtilChar(uri^), Length(uri^));
|
||||||
|
HashValue := Hash(HashValue, localName, localLength);
|
||||||
|
|
||||||
|
mask := (1 shl FSizeLog) - 1;
|
||||||
|
step := (HashValue and (not mask)) shr (FSizeLog-1) and (mask shr 2) or 1;
|
||||||
|
idx := HashValue and mask;
|
||||||
|
result := True;
|
||||||
|
while FData^[idx].rev = FRevision do
|
||||||
|
begin
|
||||||
|
if (HashValue = FData^[idx].hash) and (FData^[idx].uriPtr^ = uri^) and
|
||||||
|
(FData^[idx].lnameLen = localLength) and
|
||||||
|
CompareMem(FData^[idx].lname, localName, localLength * sizeof(TXMLUtilChar)) then
|
||||||
|
Exit;
|
||||||
|
if idx < step then
|
||||||
|
Inc(idx, (1 shl FSizeLog) - step)
|
||||||
|
else
|
||||||
|
Dec(idx, step);
|
||||||
|
end;
|
||||||
|
with FData^[idx] do
|
||||||
|
begin
|
||||||
|
rev := FRevision;
|
||||||
|
hash := HashValue;
|
||||||
|
uriPtr := uri;
|
||||||
|
lname := localName;
|
||||||
|
lnameLen := localLength;
|
||||||
|
end;
|
||||||
|
result := False;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TNSSupport }
|
||||||
|
|
||||||
|
constructor TNSSupport.Create;
|
||||||
|
var
|
||||||
|
b: TBinding;
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
FPrefixes := THashTable.Create(16, False);
|
||||||
|
FBindings := TFPList.Create;
|
||||||
|
SetLength(FBindingStack, 16);
|
||||||
|
|
||||||
|
{ provide implicit binding for the 'xml' prefix }
|
||||||
|
// TODO: move stduri_xml, etc. to this unit, so they are reused.
|
||||||
|
DefineBinding('xml', 'http://www.w3.org/XML/1998/namespace', b);
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TNSSupport.Destroy;
|
||||||
|
var
|
||||||
|
I: Integer;
|
||||||
|
begin
|
||||||
|
for I := FBindings.Count-1 downto 0 do
|
||||||
|
TObject(FBindings.List^[I]).Free;
|
||||||
|
FBindings.Free;
|
||||||
|
FPrefixes.Free;
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TNSSupport.BindPrefix(const nsURI: TXMLUtilString; aPrefix: PHashItem): TBinding;
|
||||||
|
begin
|
||||||
|
{ try to reuse an existing binding }
|
||||||
|
result := FFreeBindings;
|
||||||
|
if Assigned(result) then
|
||||||
|
FFreeBindings := result.Next
|
||||||
|
else { no free bindings, create a new one }
|
||||||
|
begin
|
||||||
|
result := TBinding.Create;
|
||||||
|
FBindings.Add(result);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ link it into chain of bindings at the current element level }
|
||||||
|
result.Next := FBindingStack[FNesting];
|
||||||
|
FBindingStack[FNesting] := result;
|
||||||
|
|
||||||
|
{ bind }
|
||||||
|
result.uri := nsURI;
|
||||||
|
result.Prefix := aPrefix;
|
||||||
|
result.PrevPrefixBinding := aPrefix^.Data;
|
||||||
|
aPrefix^.Data := result;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TNSSupport.DefaultNSBinding: TBinding;
|
||||||
|
begin
|
||||||
|
result := TBinding(FDefaultPrefix.Data);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TNSSupport.DefineBinding(const Prefix, nsURI: TXMLUtilString;
|
||||||
|
out Binding: TBinding);
|
||||||
|
var
|
||||||
|
Pfx: PHashItem;
|
||||||
|
begin
|
||||||
|
Pfx := @FDefaultPrefix;
|
||||||
|
if (nsURI <> '') and (Prefix <> '') then
|
||||||
|
Pfx := FPrefixes.FindOrAdd(PXMLUtilChar(Prefix), Length(Prefix));
|
||||||
|
if (Pfx^.Data = nil) or (TBinding(Pfx^.Data).uri <> nsURI) then
|
||||||
|
Binding := BindPrefix(nsURI, Pfx)
|
||||||
|
else
|
||||||
|
Binding := nil;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TNSSupport.CheckAttribute(const Prefix, nsURI: TXMLUtilString;
|
||||||
|
out Binding: TBinding): TAttributeAction;
|
||||||
|
var
|
||||||
|
Pfx: PHashItem;
|
||||||
|
I: Integer;
|
||||||
|
b: TBinding;
|
||||||
|
buf: array[0..31] of TXMLUtilChar;
|
||||||
|
p: PXMLUtilChar;
|
||||||
|
begin
|
||||||
|
Binding := nil;
|
||||||
|
Pfx := nil;
|
||||||
|
Result := aaUnchanged;
|
||||||
|
if Prefix <> '' then
|
||||||
|
Pfx := FPrefixes.FindOrAdd(PXMLUtilChar(Prefix), Length(Prefix))
|
||||||
|
else if nsURI = '' then
|
||||||
|
Exit;
|
||||||
|
{ if the prefix is already bound to correct URI, we're done }
|
||||||
|
if Assigned(Pfx) and Assigned(Pfx^.Data) and (TBinding(Pfx^.Data).uri = nsURI) then
|
||||||
|
Exit;
|
||||||
|
|
||||||
|
{ see if there's another prefix bound to the target URI }
|
||||||
|
// TODO: should use something faster than linear search
|
||||||
|
for i := FNesting downto 0 do
|
||||||
|
begin
|
||||||
|
b := FBindingStack[i];
|
||||||
|
while Assigned(b) do
|
||||||
|
begin
|
||||||
|
if (b.uri = nsURI) and (b.Prefix <> @FDefaultPrefix) then
|
||||||
|
begin
|
||||||
|
Binding := b; // found one -> override the attribute's prefix
|
||||||
|
Result := aaPrefix;
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
b := b.Next;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
{ no prefix, or bound (to wrong URI) -> use generated prefix instead }
|
||||||
|
if (Pfx = nil) or Assigned(Pfx^.Data) then
|
||||||
|
repeat
|
||||||
|
Inc(FPrefixSeqNo);
|
||||||
|
i := FPrefixSeqNo; // This is just 'NS'+IntToStr(FPrefixSeqNo);
|
||||||
|
p := @Buf[high(Buf)]; // done without using strings
|
||||||
|
while i <> 0 do
|
||||||
|
begin
|
||||||
|
p^ := TXMLUtilChar(i mod 10+ord('0'));
|
||||||
|
dec(p);
|
||||||
|
i := i div 10;
|
||||||
|
end;
|
||||||
|
p^ := 'S'; dec(p);
|
||||||
|
p^ := 'N';
|
||||||
|
Pfx := FPrefixes.FindOrAdd(p, @Buf[high(Buf)]-p+1);
|
||||||
|
until Pfx^.Data = nil;
|
||||||
|
Binding := BindPrefix(nsURI, Pfx);
|
||||||
|
Result := aaBoth;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TNSSupport.IsPrefixBound(P: PXMLUtilChar; Len: Integer; out
|
||||||
|
Prefix: PHashItem): Boolean;
|
||||||
|
begin
|
||||||
|
Prefix := FPrefixes.FindOrAdd(P, Len);
|
||||||
|
Result := Assigned(Prefix^.Data) and (TBinding(Prefix^.Data).uri <> '');
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TNSSupport.GetPrefix(P: PXMLUtilChar; Len: Integer): PHashItem;
|
||||||
|
begin
|
||||||
|
if Assigned(P) and (Len > 0) then
|
||||||
|
Result := FPrefixes.FindOrAdd(P, Len)
|
||||||
|
else
|
||||||
|
Result := @FDefaultPrefix;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TNSSupport.StartElement;
|
||||||
|
begin
|
||||||
|
Inc(FNesting);
|
||||||
|
if FNesting >= Length(FBindingStack) then
|
||||||
|
SetLength(FBindingStack, FNesting * 2);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TNSSupport.EndElement;
|
||||||
|
var
|
||||||
|
b, temp: TBinding;
|
||||||
|
begin
|
||||||
|
temp := FBindingStack[FNesting];
|
||||||
|
while Assigned(temp) do
|
||||||
|
begin
|
||||||
|
b := temp;
|
||||||
|
temp := b.next;
|
||||||
|
b.next := FFreeBindings;
|
||||||
|
FFreeBindings := b;
|
||||||
|
b.Prefix^.Data := b.prevPrefixBinding;
|
||||||
|
end;
|
||||||
|
FBindingStack[FNesting] := nil;
|
||||||
|
if FNesting > 0 then
|
||||||
|
Dec(FNesting);
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
initialization
|
||||||
|
|
||||||
|
finalization
|
||||||
|
if Assigned(Xml11Pg) then
|
||||||
|
FreeMem(Xml11Pg);
|
||||||
|
|
||||||
|
end.
|
||||||
890
components/codetools/laz2_xmlwrite.pas
Normal file
890
components/codetools/laz2_xmlwrite.pas
Normal file
@ -0,0 +1,890 @@
|
|||||||
|
{
|
||||||
|
This file is based on the FCL unit xmlwrite svn revision 15251.
|
||||||
|
Converted to use UTF8 instead of widestrings by Mattias Gaertner.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
XML writing routines
|
||||||
|
Copyright (c) 1999-2000 by Sebastian Guenther, sg@freepascal.org
|
||||||
|
Modified in 2006 by Sergei Gorelkin, sergei_gorelkin@mail.ru
|
||||||
|
|
||||||
|
See the file COPYING.FPC, 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 laz2_XMLWrite;
|
||||||
|
|
||||||
|
{$ifdef fpc}{$MODE objfpc}{$endif}
|
||||||
|
{$H+}
|
||||||
|
|
||||||
|
{$DEFINE UseUTF8}
|
||||||
|
{off $DEFINE UseWideString}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses Classes, laz2_DOM;
|
||||||
|
|
||||||
|
procedure WriteXMLFile(doc: TXMLDocument; const AFileName: String); overload;
|
||||||
|
procedure WriteXMLFile(doc: TXMLDocument; var AFile: Text); overload;
|
||||||
|
procedure WriteXMLFile(doc: TXMLDocument; AStream: TStream); overload;
|
||||||
|
|
||||||
|
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, xmlutils;
|
||||||
|
|
||||||
|
type
|
||||||
|
TXMLWriter = class;
|
||||||
|
TSpecialCharCallback = procedure(Sender: TXMLWriter; const s: DOMString;
|
||||||
|
var idx: Integer);
|
||||||
|
|
||||||
|
PAttrFixup = ^TAttrFixup;
|
||||||
|
TAttrFixup = record
|
||||||
|
Attr: TDOMNode;
|
||||||
|
Prefix: PHashItem;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TXMLWriter = class(TObject)
|
||||||
|
private
|
||||||
|
FInsideTextNode: Boolean;
|
||||||
|
FCanonical: Boolean;
|
||||||
|
FIndent: DOMString;
|
||||||
|
FIndentCount: Integer;
|
||||||
|
FBuffer: PChar;
|
||||||
|
FBufPos: PChar;
|
||||||
|
FCapacity: Integer;
|
||||||
|
FLineBreak: DOMString;
|
||||||
|
FNSHelper: TNSSupport;
|
||||||
|
FAttrFixups: TFPList;
|
||||||
|
FScratch: TFPList;
|
||||||
|
FNSDefs: TFPList;
|
||||||
|
procedure wrtChars(Src: DOMPChar; Length: Integer);
|
||||||
|
procedure IncIndent;
|
||||||
|
procedure DecIndent; {$IFDEF HAS_INLINE} inline; {$ENDIF}
|
||||||
|
procedure wrtStr(const ws: DOMString); {$IFDEF HAS_INLINE} inline; {$ENDIF}
|
||||||
|
procedure wrtChr(c: DOMChar); {$IFDEF HAS_INLINE} inline; {$ENDIF}
|
||||||
|
procedure wrtIndent; {$IFDEF HAS_INLINE} inline; {$ENDIF}
|
||||||
|
procedure wrtQuotedLiteral(const ws: DOMString);
|
||||||
|
procedure ConvWrite(const s: DOMString; const SpecialChars: TSetOfChar;
|
||||||
|
const SpecialCharCallback: TSpecialCharCallback);
|
||||||
|
procedure WriteNSDef(B: TBinding);
|
||||||
|
procedure NamespaceFixup(Element: TDOMElement);
|
||||||
|
protected
|
||||||
|
procedure Write(const Buffer; Count: Longint); virtual; abstract;
|
||||||
|
procedure WriteNode(Node: TDOMNode);
|
||||||
|
procedure VisitDocument(Node: TDOMNode);
|
||||||
|
procedure VisitDocument_Canonical(Node: TDOMNode);
|
||||||
|
procedure VisitElement(Node: TDOMNode);
|
||||||
|
procedure VisitText(Node: TDOMNode);
|
||||||
|
procedure VisitCDATA(Node: TDOMNode);
|
||||||
|
procedure VisitComment(Node: TDOMNode);
|
||||||
|
procedure VisitFragment(Node: TDOMNode);
|
||||||
|
procedure VisitAttribute(Node: TDOMNode);
|
||||||
|
procedure VisitEntityRef(Node: TDOMNode);
|
||||||
|
procedure VisitDocumentType(Node: TDOMNode);
|
||||||
|
procedure VisitPI(Node: TDOMNode);
|
||||||
|
public
|
||||||
|
constructor Create;
|
||||||
|
destructor Destroy; override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TTextXMLWriter = Class(TXMLWriter)
|
||||||
|
Private
|
||||||
|
F : ^Text;
|
||||||
|
Protected
|
||||||
|
Procedure Write(Const Buffer; Count : Longint);override;
|
||||||
|
Public
|
||||||
|
constructor Create(var AFile: Text);
|
||||||
|
end;
|
||||||
|
|
||||||
|
TStreamXMLWriter = Class(TXMLWriter)
|
||||||
|
Private
|
||||||
|
F : TStream;
|
||||||
|
Protected
|
||||||
|
Procedure Write(Const Buffer; Count : Longint);override;
|
||||||
|
Public
|
||||||
|
constructor Create(AStream: TStream);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ ---------------------------------------------------------------------
|
||||||
|
TTextXMLWriter
|
||||||
|
---------------------------------------------------------------------}
|
||||||
|
|
||||||
|
|
||||||
|
constructor TTextXMLWriter.Create(var AFile: Text);
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
f := @AFile;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TTextXMLWriter.Write(const Buffer; Count: Longint);
|
||||||
|
var
|
||||||
|
s: string;
|
||||||
|
begin
|
||||||
|
if Count>0 then
|
||||||
|
begin
|
||||||
|
SetString(s, PChar(@Buffer), Count);
|
||||||
|
system.Write(f^, s);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ ---------------------------------------------------------------------
|
||||||
|
TStreamXMLWriter
|
||||||
|
---------------------------------------------------------------------}
|
||||||
|
|
||||||
|
constructor TStreamXMLWriter.Create(AStream: TStream);
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
F := AStream;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure TStreamXMLWriter.Write(const Buffer; Count: Longint);
|
||||||
|
begin
|
||||||
|
if Count > 0 then
|
||||||
|
F.Write(Buffer, Count);
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
{ ---------------------------------------------------------------------
|
||||||
|
TXMLWriter
|
||||||
|
---------------------------------------------------------------------}
|
||||||
|
|
||||||
|
const
|
||||||
|
AttrSpecialChars = ['<', '"', '&', #0..#31];
|
||||||
|
TextSpecialChars = ['<', '>', '&', #0..#31];
|
||||||
|
CDSectSpecialChars = [']'];
|
||||||
|
LineEndingChars = [#13, #10];
|
||||||
|
QuotStr = '"';
|
||||||
|
AmpStr = '&';
|
||||||
|
ltStr = '<';
|
||||||
|
gtStr = '>';
|
||||||
|
HexChr: PChar = '0123456789ABCDEF';
|
||||||
|
|
||||||
|
constructor TXMLWriter.Create;
|
||||||
|
var
|
||||||
|
I: Integer;
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
// some overhead - always be able to write at least one extra UCS4
|
||||||
|
FBuffer := AllocMem(512+32);
|
||||||
|
FBufPos := FBuffer;
|
||||||
|
FCapacity := 512;
|
||||||
|
// Later on, this may be put under user control
|
||||||
|
// for now, take OS setting
|
||||||
|
if FCanonical then
|
||||||
|
FLineBreak := #10
|
||||||
|
else
|
||||||
|
FLineBreak := sLineBreak;
|
||||||
|
// Initialize Indent string
|
||||||
|
// TODO: this must be done in setter of FLineBreak
|
||||||
|
SetLength(FIndent, 100);
|
||||||
|
FIndent[1] := FLineBreak[1];
|
||||||
|
if Length(FLineBreak) > 1 then
|
||||||
|
FIndent[2] := FLineBreak[2]
|
||||||
|
else
|
||||||
|
FIndent[2] := ' ';
|
||||||
|
for I := 3 to 100 do FIndent[I] := ' ';
|
||||||
|
FIndentCount := 0;
|
||||||
|
FNSHelper := TNSSupport.Create;
|
||||||
|
FScratch := TFPList.Create;
|
||||||
|
FNSDefs := TFPList.Create;
|
||||||
|
FAttrFixups := TFPList.Create;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TXMLWriter.Destroy;
|
||||||
|
var
|
||||||
|
I: Integer;
|
||||||
|
begin
|
||||||
|
for I := FAttrFixups.Count-1 downto 0 do
|
||||||
|
Dispose(PAttrFixup(FAttrFixups.List^[I]));
|
||||||
|
FAttrFixups.Free;
|
||||||
|
FNSDefs.Free;
|
||||||
|
FScratch.Free;
|
||||||
|
FNSHelper.Free;
|
||||||
|
if FBufPos > FBuffer then
|
||||||
|
write(FBuffer^, FBufPos-FBuffer);
|
||||||
|
|
||||||
|
FreeMem(FBuffer);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.wrtChars(Src: DOMPChar; Length: Integer);
|
||||||
|
var
|
||||||
|
pb: PChar;
|
||||||
|
wc: Cardinal;
|
||||||
|
SrcEnd: DOMPChar;
|
||||||
|
begin
|
||||||
|
pb := FBufPos;
|
||||||
|
SrcEnd := Src + Length;
|
||||||
|
while Src < SrcEnd do
|
||||||
|
begin
|
||||||
|
if pb >= @FBuffer[FCapacity] then
|
||||||
|
begin
|
||||||
|
write(FBuffer^, FCapacity);
|
||||||
|
Dec(pb, FCapacity);
|
||||||
|
if pb > FBuffer then
|
||||||
|
Move(FBuffer[FCapacity], FBuffer^, pb - FBuffer);
|
||||||
|
end;
|
||||||
|
|
||||||
|
wc := Cardinal(Src^); Inc(Src);
|
||||||
|
{$IFDEF UseUTF8}
|
||||||
|
pb^ := char(wc);
|
||||||
|
Inc(pb);
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF UseWideString}
|
||||||
|
case wc of
|
||||||
|
0..$7F: begin
|
||||||
|
pb^ := char(wc); Inc(pb);
|
||||||
|
end;
|
||||||
|
|
||||||
|
$80..$7FF: begin
|
||||||
|
pb^ := Char($C0 or (wc shr 6));
|
||||||
|
pb[1] := Char($80 or (wc and $3F));
|
||||||
|
Inc(pb,2);
|
||||||
|
end;
|
||||||
|
|
||||||
|
$D800..$DBFF: begin
|
||||||
|
if (Src < SrcEnd) and (Src^ >= #$DC00) and (Src^ <= #$DFFF) then
|
||||||
|
begin
|
||||||
|
wc := ((LongInt(wc) - $D7C0) shl 10) + LongInt(word(Src^) xor $DC00);
|
||||||
|
Inc(Src);
|
||||||
|
|
||||||
|
pb^ := Char($F0 or (wc shr 18));
|
||||||
|
pb[1] := Char($80 or ((wc shr 12) and $3F));
|
||||||
|
pb[2] := Char($80 or ((wc shr 6) and $3F));
|
||||||
|
pb[3] := Char($80 or (wc and $3F));
|
||||||
|
Inc(pb,4);
|
||||||
|
end
|
||||||
|
else
|
||||||
|
raise EConvertError.Create('High surrogate without low one');
|
||||||
|
end;
|
||||||
|
$DC00..$DFFF:
|
||||||
|
raise EConvertError.Create('Low surrogate without high one');
|
||||||
|
else // $800 >= wc > $FFFF, excluding surrogates
|
||||||
|
begin
|
||||||
|
pb^ := Char($E0 or (wc shr 12));
|
||||||
|
pb[1] := Char($80 or ((wc shr 6) and $3F));
|
||||||
|
pb[2] := Char($80 or (wc and $3F));
|
||||||
|
Inc(pb,3);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
{$ENDIF UseWideString}
|
||||||
|
end;
|
||||||
|
FBufPos := pb;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.wrtStr(const ws: DOMString); { inline }
|
||||||
|
begin
|
||||||
|
wrtChars(DOMPChar(ws), Length(ws));
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ No checks here - buffer always has 32 extra bytes }
|
||||||
|
procedure TXMLWriter.wrtChr(c: DOMChar); { inline }
|
||||||
|
begin
|
||||||
|
FBufPos^ := char(ord(c));
|
||||||
|
Inc(FBufPos);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.wrtIndent; { inline }
|
||||||
|
begin
|
||||||
|
wrtChars(DOMPChar(FIndent), FIndentCount*2+Length(FLineBreak));
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.IncIndent;
|
||||||
|
var
|
||||||
|
I, NewLen, OldLen: Integer;
|
||||||
|
begin
|
||||||
|
Inc(FIndentCount);
|
||||||
|
if Length(FIndent) < 2 * FIndentCount then
|
||||||
|
begin
|
||||||
|
OldLen := Length(FIndent);
|
||||||
|
NewLen := 4 * FIndentCount;
|
||||||
|
SetLength(FIndent, NewLen);
|
||||||
|
for I := OldLen to NewLen do
|
||||||
|
FIndent[I] := ' ';
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.DecIndent; { inline }
|
||||||
|
begin
|
||||||
|
if FIndentCount>0 then dec(FIndentCount);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.ConvWrite(const s: DOMString; const SpecialChars: TSetOfChar;
|
||||||
|
const SpecialCharCallback: TSpecialCharCallback);
|
||||||
|
var
|
||||||
|
StartPos, EndPos: Integer;
|
||||||
|
begin
|
||||||
|
StartPos := 1;
|
||||||
|
EndPos := 1;
|
||||||
|
while EndPos <= Length(s) do
|
||||||
|
begin
|
||||||
|
if (s[EndPos] < #128) and (Char(ord(s[EndPos])) in SpecialChars) then
|
||||||
|
begin
|
||||||
|
wrtChars(@s[StartPos], EndPos - StartPos);
|
||||||
|
SpecialCharCallback(Self, s, EndPos);
|
||||||
|
StartPos := EndPos + 1;
|
||||||
|
end;
|
||||||
|
Inc(EndPos);
|
||||||
|
end;
|
||||||
|
if StartPos <= length(s) then
|
||||||
|
wrtChars(@s[StartPos], EndPos - StartPos);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure AttrSpecialCharCallback(Sender: TXMLWriter; const s: DOMString;
|
||||||
|
var idx: Integer);
|
||||||
|
begin
|
||||||
|
case s[idx] of
|
||||||
|
'"': Sender.wrtStr(QuotStr);
|
||||||
|
'&': Sender.wrtStr(AmpStr);
|
||||||
|
'<': Sender.wrtStr(ltStr);
|
||||||
|
// Escape whitespace using CharRefs to be consistent with W3 spec § 3.3.3
|
||||||
|
#0..#15: Sender.wrtStr('&#x'+HexChr[ord(s[idx])]+';');
|
||||||
|
#16..#31: Sender.wrtStr(''+HexChr[ord(s[idx])-16]+';');
|
||||||
|
else
|
||||||
|
Sender.wrtChr(s[idx]);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TextnodeNormalCallback(Sender: TXMLWriter; const s: DOMString;
|
||||||
|
var idx: Integer);
|
||||||
|
begin
|
||||||
|
case s[idx] of
|
||||||
|
'<': Sender.wrtStr(ltStr);
|
||||||
|
'>': Sender.wrtStr(gtStr); // Required only in ']]>' literal, otherwise optional
|
||||||
|
'&': Sender.wrtStr(AmpStr);
|
||||||
|
#13:
|
||||||
|
begin
|
||||||
|
// We normalize #13#10 and #13 to FLineBreak, going somewhat
|
||||||
|
// beyond the specs here, see issue #13879.
|
||||||
|
Sender.wrtStr(Sender.FLineBreak);
|
||||||
|
if (idx < Length(s)) and (s[idx+1] = #10) then
|
||||||
|
Inc(idx);
|
||||||
|
end;
|
||||||
|
#10: Sender.wrtStr(Sender.FLineBreak);
|
||||||
|
#0..#9,#11..#12,#14..#15: Sender.wrtStr('&#x'+HexChr[ord(s[idx])]+';');
|
||||||
|
#16..#31: Sender.wrtStr(''+HexChr[ord(s[idx])-16]+';');
|
||||||
|
else
|
||||||
|
Sender.wrtChr(s[idx]);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TextnodeCanonicalCallback(Sender: TXMLWriter; const s: DOMString;
|
||||||
|
var idx: Integer);
|
||||||
|
begin
|
||||||
|
case s[idx] of
|
||||||
|
'<': Sender.wrtStr(ltStr);
|
||||||
|
'>': Sender.wrtStr(gtStr);
|
||||||
|
'&': Sender.wrtStr(AmpStr);
|
||||||
|
#0..#15: Sender.wrtStr('&#x'+HexChr[ord(s[idx])]+';');
|
||||||
|
#16..#31: Sender.wrtStr(''+HexChr[ord(s[idx])-16]+';');
|
||||||
|
else
|
||||||
|
Sender.wrtChr(s[idx]);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure CDSectSpecialCharCallback(Sender: TXMLWriter; const s: DOMString;
|
||||||
|
var idx: Integer);
|
||||||
|
begin
|
||||||
|
if (idx <= Length(s)-2) and (s[idx+1] = ']') and (s[idx+2] = '>') then
|
||||||
|
begin
|
||||||
|
Sender.wrtStr(']]]]><![CDATA[>');
|
||||||
|
Inc(idx, 2);
|
||||||
|
// TODO: emit warning 'cdata-section-splitted'
|
||||||
|
end
|
||||||
|
else
|
||||||
|
Sender.wrtChr(s[idx]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
const
|
||||||
|
TextnodeCallbacks: array[boolean] of TSpecialCharCallback = (
|
||||||
|
@TextnodeNormalCallback,
|
||||||
|
@TextnodeCanonicalCallback
|
||||||
|
);
|
||||||
|
|
||||||
|
procedure TXMLWriter.wrtQuotedLiteral(const ws: DOMString);
|
||||||
|
var
|
||||||
|
Quote: DOMChar;
|
||||||
|
begin
|
||||||
|
// TODO: need to check if the string also contains single quote
|
||||||
|
// both quotes present is a error
|
||||||
|
if Pos('"', ws) > 0 then
|
||||||
|
Quote := ''''
|
||||||
|
else
|
||||||
|
Quote := '"';
|
||||||
|
wrtChr(Quote);
|
||||||
|
ConvWrite(ws, LineEndingChars, @TextnodeNormalCallback);
|
||||||
|
wrtChr(Quote);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.WriteNode(node: TDOMNode);
|
||||||
|
begin
|
||||||
|
case node.NodeType of
|
||||||
|
ELEMENT_NODE: VisitElement(node);
|
||||||
|
ATTRIBUTE_NODE: VisitAttribute(node);
|
||||||
|
TEXT_NODE: VisitText(node);
|
||||||
|
CDATA_SECTION_NODE: VisitCDATA(node);
|
||||||
|
ENTITY_REFERENCE_NODE: VisitEntityRef(node);
|
||||||
|
PROCESSING_INSTRUCTION_NODE: VisitPI(node);
|
||||||
|
COMMENT_NODE: VisitComment(node);
|
||||||
|
DOCUMENT_NODE:
|
||||||
|
if FCanonical then
|
||||||
|
VisitDocument_Canonical(node)
|
||||||
|
else
|
||||||
|
VisitDocument(node);
|
||||||
|
DOCUMENT_TYPE_NODE: VisitDocumentType(node);
|
||||||
|
ENTITY_NODE,
|
||||||
|
DOCUMENT_FRAGMENT_NODE: VisitFragment(node);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.WriteNSDef(B: TBinding);
|
||||||
|
begin
|
||||||
|
wrtChars(' xmlns', 6);
|
||||||
|
if B.Prefix^.Key <> '' then
|
||||||
|
begin
|
||||||
|
wrtChr(':');
|
||||||
|
wrtStr(B.Prefix^.Key);
|
||||||
|
end;
|
||||||
|
wrtChars('="', 2);
|
||||||
|
ConvWrite(B.uri, AttrSpecialChars, @AttrSpecialCharCallback);
|
||||||
|
wrtChr('"');
|
||||||
|
end;
|
||||||
|
|
||||||
|
function Compare(const s1, s2: DOMString): integer;
|
||||||
|
var
|
||||||
|
maxi, temp: integer;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
if pointer(S1) = pointer(S2) then
|
||||||
|
exit;
|
||||||
|
maxi := Length(S1);
|
||||||
|
temp := Length(S2);
|
||||||
|
if maxi > temp then
|
||||||
|
maxi := temp;
|
||||||
|
Result := CompareWord(S1[1], S2[1], maxi);
|
||||||
|
if Result = 0 then
|
||||||
|
Result := Length(S1)-Length(S2);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function SortNSDefs(Item1, Item2: Pointer): Integer;
|
||||||
|
begin
|
||||||
|
Result := Compare(TBinding(Item1).Prefix^.Key, TBinding(Item2).Prefix^.Key);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function SortAtts(Item1, Item2: Pointer): Integer;
|
||||||
|
var
|
||||||
|
p1: PAttrFixup absolute Item1;
|
||||||
|
p2: PAttrFixup absolute Item2;
|
||||||
|
s1, s2: DOMString;
|
||||||
|
begin
|
||||||
|
Result := Compare(p1^.Attr.namespaceURI, p2^.Attr.namespaceURI);
|
||||||
|
if Result = 0 then
|
||||||
|
begin
|
||||||
|
// TODO: Must fix the parser so it doesn't produce Level 1 attributes
|
||||||
|
if nfLevel2 in p1^.Attr.Flags then
|
||||||
|
s1 := p1^.Attr.localName
|
||||||
|
else
|
||||||
|
s1 := p1^.Attr.nodeName;
|
||||||
|
if nfLevel2 in p2^.Attr.Flags then
|
||||||
|
s2 := p2^.Attr.localName
|
||||||
|
else
|
||||||
|
s2 := p2^.Attr.nodeName;
|
||||||
|
Result := Compare(s1, s2);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.NamespaceFixup(Element: TDOMElement);
|
||||||
|
var
|
||||||
|
B: TBinding;
|
||||||
|
i, j: Integer;
|
||||||
|
node: TDOMNode;
|
||||||
|
s: DOMString;
|
||||||
|
action: TAttributeAction;
|
||||||
|
p: PAttrFixup;
|
||||||
|
begin
|
||||||
|
FScratch.Count := 0;
|
||||||
|
FNSDefs.Count := 0;
|
||||||
|
if Element.hasAttributes then
|
||||||
|
begin
|
||||||
|
j := 0;
|
||||||
|
for i := 0 to Element.Attributes.Length-1 do
|
||||||
|
begin
|
||||||
|
node := Element.Attributes[i];
|
||||||
|
if TDOMNode_NS(node).NSI.NSIndex = 2 then
|
||||||
|
begin
|
||||||
|
if TDOMNode_NS(node).NSI.PrefixLen = 0 then
|
||||||
|
s := ''
|
||||||
|
else
|
||||||
|
s := node.localName;
|
||||||
|
FNSHelper.DefineBinding(s, node.nodeValue, B);
|
||||||
|
if Assigned(B) then // drop redundant namespace declarations
|
||||||
|
FNSDefs.Add(B);
|
||||||
|
end
|
||||||
|
else if FCanonical or TDOMAttr(node).Specified then
|
||||||
|
begin
|
||||||
|
// obtain a TAttrFixup record (allocate if needed)
|
||||||
|
if j >= FAttrFixups.Count then
|
||||||
|
begin
|
||||||
|
New(p);
|
||||||
|
FAttrFixups.Add(p);
|
||||||
|
end
|
||||||
|
else
|
||||||
|
p := PAttrFixup(FAttrFixups.List^[j]);
|
||||||
|
// add it to the working list
|
||||||
|
p^.Attr := node;
|
||||||
|
p^.Prefix := nil;
|
||||||
|
FScratch.Add(p);
|
||||||
|
Inc(j);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
FNSHelper.DefineBinding(Element.Prefix, Element.namespaceURI, B);
|
||||||
|
if Assigned(B) then
|
||||||
|
FNSDefs.Add(B);
|
||||||
|
|
||||||
|
for i := 0 to FScratch.Count-1 do
|
||||||
|
begin
|
||||||
|
node := PAttrFixup(FScratch.List^[i])^.Attr;
|
||||||
|
action := FNSHelper.CheckAttribute(node.Prefix, node.namespaceURI, B);
|
||||||
|
if action = aaBoth then
|
||||||
|
FNSDefs.Add(B);
|
||||||
|
|
||||||
|
if action in [aaPrefix, aaBoth] then
|
||||||
|
PAttrFixup(FScratch.List^[i])^.Prefix := B.Prefix;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if FCanonical then
|
||||||
|
begin
|
||||||
|
FNSDefs.Sort(@SortNSDefs);
|
||||||
|
FScratch.Sort(@SortAtts);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// now, at last, dump all this stuff.
|
||||||
|
for i := 0 to FNSDefs.Count-1 do
|
||||||
|
WriteNSDef(TBinding(FNSDefs.List^[I]));
|
||||||
|
|
||||||
|
for i := 0 to FScratch.Count-1 do
|
||||||
|
begin
|
||||||
|
wrtChr(' ');
|
||||||
|
with PAttrFixup(FScratch.List^[I])^ do
|
||||||
|
begin
|
||||||
|
if Assigned(Prefix) then
|
||||||
|
begin
|
||||||
|
wrtStr(Prefix^.Key);
|
||||||
|
wrtChr(':');
|
||||||
|
wrtStr(Attr.localName);
|
||||||
|
end
|
||||||
|
else
|
||||||
|
wrtStr(Attr.nodeName);
|
||||||
|
|
||||||
|
wrtChars('="', 2);
|
||||||
|
// TODO: not correct w.r.t. entities
|
||||||
|
ConvWrite(attr.nodeValue, AttrSpecialChars, @AttrSpecialCharCallback);
|
||||||
|
wrtChr('"');
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.VisitElement(node: TDOMNode);
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
|
child: TDOMNode;
|
||||||
|
SavedInsideTextNode: Boolean;
|
||||||
|
begin
|
||||||
|
if not FInsideTextNode then
|
||||||
|
wrtIndent;
|
||||||
|
FNSHelper.StartElement;
|
||||||
|
wrtChr('<');
|
||||||
|
wrtStr(TDOMElement(node).TagName);
|
||||||
|
|
||||||
|
if nfLevel2 in node.Flags then
|
||||||
|
NamespaceFixup(TDOMElement(node))
|
||||||
|
else if node.HasAttributes then
|
||||||
|
for i := 0 to node.Attributes.Length - 1 do
|
||||||
|
begin
|
||||||
|
child := node.Attributes.Item[i];
|
||||||
|
if FCanonical or TDOMAttr(child).Specified then
|
||||||
|
VisitAttribute(child);
|
||||||
|
end;
|
||||||
|
Child := node.FirstChild;
|
||||||
|
if Child = nil then
|
||||||
|
wrtChars('/>', 2)
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
SavedInsideTextNode := FInsideTextNode;
|
||||||
|
wrtChr('>');
|
||||||
|
FInsideTextNode := FCanonical or (Child.NodeType in [TEXT_NODE, CDATA_SECTION_NODE]);
|
||||||
|
IncIndent;
|
||||||
|
repeat
|
||||||
|
WriteNode(Child);
|
||||||
|
Child := Child.NextSibling;
|
||||||
|
until Child = nil;
|
||||||
|
DecIndent;
|
||||||
|
if not (node.LastChild.NodeType in [TEXT_NODE, CDATA_SECTION_NODE]) then
|
||||||
|
wrtIndent;
|
||||||
|
FInsideTextNode := SavedInsideTextNode;
|
||||||
|
wrtChars('</', 2);
|
||||||
|
wrtStr(TDOMElement(Node).TagName);
|
||||||
|
wrtChr('>');
|
||||||
|
end;
|
||||||
|
FNSHelper.EndElement;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.VisitText(node: TDOMNode);
|
||||||
|
begin
|
||||||
|
ConvWrite(TDOMCharacterData(node).Data, TextSpecialChars, TextnodeCallbacks[FCanonical]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.VisitCDATA(node: TDOMNode);
|
||||||
|
begin
|
||||||
|
if not FInsideTextNode then
|
||||||
|
wrtIndent;
|
||||||
|
if FCanonical then
|
||||||
|
ConvWrite(TDOMCharacterData(node).Data, TextSpecialChars, @TextnodeCanonicalCallback)
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
wrtChars('<![CDATA[', 9);
|
||||||
|
ConvWrite(TDOMCharacterData(node).Data, CDSectSpecialChars, @CDSectSpecialCharCallback);
|
||||||
|
wrtChars(']]>', 3);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.VisitEntityRef(node: TDOMNode);
|
||||||
|
begin
|
||||||
|
wrtChr('&');
|
||||||
|
wrtStr(node.NodeName);
|
||||||
|
wrtChr(';');
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.VisitPI(node: TDOMNode);
|
||||||
|
begin
|
||||||
|
if not FInsideTextNode then wrtIndent;
|
||||||
|
wrtStr('<?');
|
||||||
|
wrtStr(TDOMProcessingInstruction(node).Target);
|
||||||
|
if TDOMProcessingInstruction(node).Data <> '' then
|
||||||
|
begin
|
||||||
|
wrtChr(' ');
|
||||||
|
// TODO: How does this comply with c14n??
|
||||||
|
ConvWrite(TDOMProcessingInstruction(node).Data, LineEndingChars, @TextnodeNormalCallback);
|
||||||
|
end;
|
||||||
|
wrtStr('?>');
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.VisitComment(node: TDOMNode);
|
||||||
|
begin
|
||||||
|
if not FInsideTextNode then wrtIndent;
|
||||||
|
wrtChars('<!--', 4);
|
||||||
|
// TODO: How does this comply with c14n??
|
||||||
|
ConvWrite(TDOMCharacterData(node).Data, LineEndingChars, @TextnodeNormalCallback);
|
||||||
|
wrtChars('-->', 3);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.VisitDocument(node: TDOMNode);
|
||||||
|
var
|
||||||
|
child: TDOMNode;
|
||||||
|
begin
|
||||||
|
wrtStr('<?xml version="');
|
||||||
|
// Definitely should not escape anything here
|
||||||
|
if Length(TXMLDocument(node).XMLVersion) > 0 then
|
||||||
|
wrtStr(TXMLDocument(node).XMLVersion)
|
||||||
|
else
|
||||||
|
wrtStr('1.0');
|
||||||
|
wrtChr('"');
|
||||||
|
|
||||||
|
// DISABLED - we are only able write in UTF-8 which does not require labeling
|
||||||
|
// writing incorrect encoding will render xml unreadable...
|
||||||
|
(*
|
||||||
|
if Length(TXMLDocument(node).Encoding) > 0 then
|
||||||
|
begin
|
||||||
|
wrtStr(' encoding="');
|
||||||
|
wrtStr(TXMLDocument(node).Encoding);
|
||||||
|
wrtChr('"');
|
||||||
|
end;
|
||||||
|
*)
|
||||||
|
wrtStr('?>');
|
||||||
|
|
||||||
|
// TODO: now handled as a regular PI, remove this?
|
||||||
|
if Length(TXMLDocument(node).StylesheetType) > 0 then
|
||||||
|
begin
|
||||||
|
wrtStr(FLineBreak);
|
||||||
|
wrtStr('<?xml-stylesheet type="');
|
||||||
|
wrtStr(TXMLDocument(node).StylesheetType);
|
||||||
|
wrtStr('" href="');
|
||||||
|
wrtStr(TXMLDocument(node).StylesheetHRef);
|
||||||
|
wrtStr('"?>');
|
||||||
|
end;
|
||||||
|
|
||||||
|
child := node.FirstChild;
|
||||||
|
while Assigned(Child) do
|
||||||
|
begin
|
||||||
|
WriteNode(Child);
|
||||||
|
Child := Child.NextSibling;
|
||||||
|
end;
|
||||||
|
wrtStr(FLineBreak);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.VisitDocument_Canonical(Node: TDOMNode);
|
||||||
|
var
|
||||||
|
child, root: TDOMNode;
|
||||||
|
begin
|
||||||
|
root := TDOMDocument(Node).DocumentElement;
|
||||||
|
child := node.FirstChild;
|
||||||
|
while Assigned(child) and (child <> root) do
|
||||||
|
begin
|
||||||
|
if child.nodeType in [COMMENT_NODE, PROCESSING_INSTRUCTION_NODE] then
|
||||||
|
begin
|
||||||
|
WriteNode(child);
|
||||||
|
wrtChr(#10);
|
||||||
|
end;
|
||||||
|
child := child.nextSibling;
|
||||||
|
end;
|
||||||
|
if root = nil then
|
||||||
|
Exit;
|
||||||
|
VisitElement(TDOMElement(root));
|
||||||
|
child := root.nextSibling;
|
||||||
|
while Assigned(child) do
|
||||||
|
begin
|
||||||
|
if child.nodeType in [COMMENT_NODE, PROCESSING_INSTRUCTION_NODE] then
|
||||||
|
begin
|
||||||
|
wrtChr(#10);
|
||||||
|
WriteNode(child);
|
||||||
|
end;
|
||||||
|
child := child.nextSibling;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.VisitAttribute(Node: TDOMNode);
|
||||||
|
var
|
||||||
|
Child: TDOMNode;
|
||||||
|
begin
|
||||||
|
wrtChr(' ');
|
||||||
|
wrtStr(TDOMAttr(Node).Name);
|
||||||
|
wrtChars('="', 2);
|
||||||
|
Child := Node.FirstChild;
|
||||||
|
while Assigned(Child) do
|
||||||
|
begin
|
||||||
|
writeln('TXMLWriter.VisitAttribute ',Child.NodeType);
|
||||||
|
case Child.NodeType of
|
||||||
|
ENTITY_REFERENCE_NODE:
|
||||||
|
VisitEntityRef(Child);
|
||||||
|
TEXT_NODE:
|
||||||
|
ConvWrite(TDOMCharacterData(Child).Data, AttrSpecialChars, @AttrSpecialCharCallback);
|
||||||
|
end;
|
||||||
|
Child := Child.NextSibling;
|
||||||
|
end;
|
||||||
|
wrtChr('"');
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.VisitDocumentType(Node: TDOMNode);
|
||||||
|
begin
|
||||||
|
wrtStr(FLineBreak);
|
||||||
|
wrtStr('<!DOCTYPE ');
|
||||||
|
wrtStr(Node.NodeName);
|
||||||
|
wrtChr(' ');
|
||||||
|
with TDOMDocumentType(Node) do
|
||||||
|
begin
|
||||||
|
if PublicID <> '' then
|
||||||
|
begin
|
||||||
|
wrtStr('PUBLIC ');
|
||||||
|
wrtQuotedLiteral(PublicID);
|
||||||
|
wrtChr(' ');
|
||||||
|
wrtQuotedLiteral(SystemID);
|
||||||
|
end
|
||||||
|
else if SystemID <> '' then
|
||||||
|
begin
|
||||||
|
wrtStr('SYSTEM ');
|
||||||
|
wrtQuotedLiteral(SystemID);
|
||||||
|
end;
|
||||||
|
if InternalSubset <> '' then
|
||||||
|
begin
|
||||||
|
wrtChr('[');
|
||||||
|
ConvWrite(InternalSubset, LineEndingChars, @TextnodeNormalCallback);
|
||||||
|
wrtChr(']');
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
wrtChr('>');
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TXMLWriter.VisitFragment(Node: TDOMNode);
|
||||||
|
var
|
||||||
|
Child: TDOMNode;
|
||||||
|
begin
|
||||||
|
// TODO: TextDecl is probably needed
|
||||||
|
// Fragment itself should not be written, only its children should...
|
||||||
|
Child := Node.FirstChild;
|
||||||
|
while Assigned(Child) do
|
||||||
|
begin
|
||||||
|
WriteNode(Child);
|
||||||
|
Child := Child.NextSibling;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
// -------------------------------------------------------------------
|
||||||
|
// Interface implementation
|
||||||
|
// -------------------------------------------------------------------
|
||||||
|
|
||||||
|
procedure WriteXMLFile(doc: TXMLDocument; const AFileName: String);
|
||||||
|
var
|
||||||
|
fs: TFileStream;
|
||||||
|
begin
|
||||||
|
fs := TFileStream.Create(AFileName, fmCreate);
|
||||||
|
try
|
||||||
|
WriteXMLFile(doc, fs);
|
||||||
|
finally
|
||||||
|
fs.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure WriteXMLFile(doc: TXMLDocument; var AFile: Text);
|
||||||
|
begin
|
||||||
|
with TTextXMLWriter.Create(AFile) do
|
||||||
|
try
|
||||||
|
WriteNode(doc);
|
||||||
|
finally
|
||||||
|
Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure WriteXMLFile(doc: TXMLDocument; AStream: TStream);
|
||||||
|
begin
|
||||||
|
with TStreamXMLWriter.Create(AStream) do
|
||||||
|
try
|
||||||
|
WriteNode(doc);
|
||||||
|
finally
|
||||||
|
Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure WriteXML(Element: TDOMNode; const AFileName: String);
|
||||||
|
begin
|
||||||
|
WriteXMLFile(TXMLDocument(Element), AFileName);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure WriteXML(Element: TDOMNode; var AFile: Text);
|
||||||
|
begin
|
||||||
|
WriteXMLFile(TXMLDocument(Element), AFile);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure WriteXML(Element: TDOMNode; AStream: TStream);
|
||||||
|
begin
|
||||||
|
WriteXMLFile(TXMLDocument(Element), AStream);
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
end.
|
||||||
@ -1,12 +1,7 @@
|
|||||||
{
|
|
||||||
BEWARE !!!
|
|
||||||
This is a TEMPORARY file.
|
|
||||||
As soon as it is moved to the fcl, it will be removed.
|
|
||||||
}
|
|
||||||
|
|
||||||
{
|
{
|
||||||
$Id$
|
$Id$
|
||||||
This file is part of the Free Component Library
|
This file was part of the Free Component Library and was adapted to use UTF8
|
||||||
|
strings instead of widestrings.
|
||||||
|
|
||||||
Implementation of TXMLConfig class
|
Implementation of TXMLConfig class
|
||||||
Copyright (c) 1999 - 2001 by Sebastian Guenther, sg@freepascal.org
|
Copyright (c) 1999 - 2001 by Sebastian Guenther, sg@freepascal.org
|
||||||
@ -34,9 +29,16 @@ interface
|
|||||||
|
|
||||||
{off $DEFINE MEM_CHECK}
|
{off $DEFINE MEM_CHECK}
|
||||||
|
|
||||||
|
|
||||||
uses
|
uses
|
||||||
{$IFDEF MEM_CHECK}MemCheck,{$ENDIF}
|
{$IFDEF MEM_CHECK}MemCheck,{$ENDIF}
|
||||||
Classes, Laz_DOM, Laz_XMLRead, Laz_XMLWrite, FileProcs;
|
Classes, sysutils,
|
||||||
|
{$IFDEF NewXMLCfg}
|
||||||
|
Laz2_DOM, Laz2_XMLRead, Laz2_XMLWrite,
|
||||||
|
{$ELSE}
|
||||||
|
Laz_DOM, Laz_XMLRead, Laz_XMLWrite,
|
||||||
|
{$ENDIF}
|
||||||
|
FileProcs;
|
||||||
|
|
||||||
type
|
type
|
||||||
|
|
||||||
@ -50,6 +52,9 @@ type
|
|||||||
TXMLConfig = class(TComponent)
|
TXMLConfig = class(TComponent)
|
||||||
private
|
private
|
||||||
FFilename: String;
|
FFilename: String;
|
||||||
|
{$IFDEF NewXMLCfg}
|
||||||
|
FReadFlags: TXMLReaderFlags;
|
||||||
|
{$ENDIF}
|
||||||
procedure SetFilename(const AFilename: String);
|
procedure SetFilename(const AFilename: String);
|
||||||
protected
|
protected
|
||||||
doc: TXMLDocument;
|
doc: TXMLDocument;
|
||||||
@ -93,6 +98,9 @@ type
|
|||||||
published
|
published
|
||||||
property Filename: String read FFilename write SetFilename;
|
property Filename: String read FFilename write SetFilename;
|
||||||
property Document: TXMLDocument read doc;
|
property Document: TXMLDocument read doc;
|
||||||
|
{$IFDEF NewXMLCfg}
|
||||||
|
property ReadFlags: TXMLReaderFlags read FReadFlags write FReadFlags;
|
||||||
|
{$ENDIF}
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
|
||||||
@ -100,12 +108,12 @@ type
|
|||||||
|
|
||||||
implementation
|
implementation
|
||||||
|
|
||||||
uses SysUtils;
|
|
||||||
|
|
||||||
|
|
||||||
constructor TXMLConfig.Create(const AFilename: String);
|
constructor TXMLConfig.Create(const AFilename: String);
|
||||||
begin
|
begin
|
||||||
//DebugLn(['TXMLConfig.Create ',AFilename]);
|
//DebugLn(['TXMLConfig.Create ',AFilename]);
|
||||||
|
{$IFDEF NewXMLCfg}
|
||||||
|
FReadFlags:=[xrfAllowLowerThanInAttributeValue,xrfAllowSpecialCharsInAttributeValue];
|
||||||
|
{$ENDIF}
|
||||||
inherited Create(nil);
|
inherited Create(nil);
|
||||||
SetFilename(AFilename);
|
SetFilename(AFilename);
|
||||||
end;
|
end;
|
||||||
@ -113,6 +121,9 @@ end;
|
|||||||
constructor TXMLConfig.CreateClean(const AFilename: String);
|
constructor TXMLConfig.CreateClean(const AFilename: String);
|
||||||
begin
|
begin
|
||||||
//DebugLn(['TXMLConfig.CreateClean ',AFilename]);
|
//DebugLn(['TXMLConfig.CreateClean ',AFilename]);
|
||||||
|
{$IFDEF NewXMLCfg}
|
||||||
|
FReadFlags:=[xrfAllowLowerThanInAttributeValue,xrfAllowSpecialCharsInAttributeValue];
|
||||||
|
{$ENDIF}
|
||||||
inherited Create(nil);
|
inherited Create(nil);
|
||||||
fDoNotLoadFromFile:=true;
|
fDoNotLoadFromFile:=true;
|
||||||
SetFilename(AFilename);
|
SetFilename(AFilename);
|
||||||
@ -167,14 +178,22 @@ end;
|
|||||||
procedure TXMLConfig.ReadFromStream(s: TStream);
|
procedure TXMLConfig.ReadFromStream(s: TStream);
|
||||||
begin
|
begin
|
||||||
FreeDoc;
|
FreeDoc;
|
||||||
|
{$IFDEF NewXMLCfg}
|
||||||
|
Laz2_XMLRead.ReadXMLFile(Doc,s,ReadFlags);
|
||||||
|
{$ELSE}
|
||||||
Laz_XMLRead.ReadXMLFile(Doc,s);
|
Laz_XMLRead.ReadXMLFile(Doc,s);
|
||||||
|
{$ENDIF}
|
||||||
if Doc=nil then
|
if Doc=nil then
|
||||||
Clear;
|
Clear;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TXMLConfig.WriteToStream(s: TStream);
|
procedure TXMLConfig.WriteToStream(s: TStream);
|
||||||
begin
|
begin
|
||||||
|
{$IFDEF NewXMLCfg}
|
||||||
|
Laz2_XMLWrite.WriteXMLFile(Doc,s);
|
||||||
|
{$ELSE}
|
||||||
Laz_XMLWrite.WriteXMLFile(Doc,s);
|
Laz_XMLWrite.WriteXMLFile(Doc,s);
|
||||||
|
{$ENDIF}
|
||||||
end;
|
end;
|
||||||
|
|
||||||
function TXMLConfig.GetValue(const APath, ADefault: String): String;
|
function TXMLConfig.GetValue(const APath, ADefault: String): String;
|
||||||
@ -445,12 +464,20 @@ end;
|
|||||||
procedure TXMLConfig.ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String
|
procedure TXMLConfig.ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String
|
||||||
);
|
);
|
||||||
begin
|
begin
|
||||||
|
{$IFDEF NewXMLCfg}
|
||||||
|
Laz2_XMLRead.ReadXMLFile(ADoc,AFilename,ReadFlags);
|
||||||
|
{$ELSE}
|
||||||
Laz_XMLRead.ReadXMLFile(ADoc,AFilename);
|
Laz_XMLRead.ReadXMLFile(ADoc,AFilename);
|
||||||
|
{$ENDIF}
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TXMLConfig.WriteXMLFile(ADoc: TXMLDocument; const AFileName: String);
|
procedure TXMLConfig.WriteXMLFile(ADoc: TXMLDocument; const AFileName: String);
|
||||||
begin
|
begin
|
||||||
|
{$IFDEF NewXMLCfg}
|
||||||
|
Laz2_XMLWrite.WriteXMLFile(ADoc,AFileName);
|
||||||
|
{$ELSE}
|
||||||
Laz_XMLWrite.WriteXMLFile(ADoc,AFileName);
|
Laz_XMLWrite.WriteXMLFile(ADoc,AFileName);
|
||||||
|
{$ENDIF}
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TXMLConfig.FreeDoc;
|
procedure TXMLConfig.FreeDoc;
|
||||||
@ -484,7 +511,11 @@ begin
|
|||||||
try
|
try
|
||||||
ms.Write(fAutoLoadFromSource[1],length(fAutoLoadFromSource));
|
ms.Write(fAutoLoadFromSource[1],length(fAutoLoadFromSource));
|
||||||
ms.Position:=0;
|
ms.Position:=0;
|
||||||
|
{$IFDEF NewXMLCfg}
|
||||||
|
Laz2_XMLRead.ReadXMLFile(doc,ms,ReadFlags);
|
||||||
|
{$ELSE}
|
||||||
Laz_XMLRead.ReadXMLFile(doc,ms);
|
Laz_XMLRead.ReadXMLFile(doc,ms);
|
||||||
|
{$ENDIF}
|
||||||
finally
|
finally
|
||||||
ms.Free;
|
ms.Free;
|
||||||
end;
|
end;
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user