paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-01 21:20:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

added updated xmlreader/writer units

Browse Source 
git-svn-id: trunk@25342 -
This commit is contained in:
mattias 2010-05-12 19:50:23 +00:00
parent ad08a450e3
commit 7d34ac4326
10 changed files with 9518 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.gitattributes vendored
View File

@ -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.ua.po svneol=native#text/plain
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_xmlcfg.pas svneol=native#text/pascal
components/codetools/laz_xmlread.pas svneol=native#text/pascal

18
components/codetools/codetools.lpk
View File

@ -26,7 +26,7 @@
<License Value="GPL-2
"/>
<Version Major="1" Release="1"/>
<Files Count="57">
<Files Count="61">
<Item1>
<Filename Value="Makefile"/>
<Type Value="Text"/>
@ -256,6 +256,22 @@
<Filename Value="fpcsrcrules.inc"/>
<Type Value="Include"/>
</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>
<i18n>
<EnableI18N Value="True"/>

6
components/codetools/codetools.pas
View File

@ -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.
}
@ -17,8 +17,8 @@ uses
Laz_XMLStreaming, Laz_XMLWrite, LFMTrees, LinkScanner, MethodJumpTool,
MultiKeyWordListTool, NonPascalCodeTools, PascalParserTool,
PascalReaderTool, PPUCodeTools, PPUGraph, PPUParser, ResourceCodeTool,
SourceChanger, SourceLog, StdCodeTools, OtherIdentifierTree,
LazarusPackageIntf;
SourceChanger, SourceLog, StdCodeTools, OtherIdentifierTree, laz2_xmlutils,
laz2_DOM, laz2_XMLWrite, laz2_XMLRead, LazarusPackageIntf;
implementation

17
components/codetools/codetoolsconfig.pas
View File

@ -47,8 +47,13 @@ unit CodeToolsConfig;
interface
uses
Classes, SysUtils, Laz_XMLCfg, Laz_XMLRead, Laz_XMLWrite, Laz_DOM, FileProcs,
CodeCache, DefineTemplates;
Classes, SysUtils, Laz_XMLCfg,
{$IFDEF NewXMLCfg}
Laz2_XMLRead, Laz2_XMLWrite, Laz2_DOM,
{$ELSE}
Laz_XMLRead, Laz_XMLWrite, Laz_DOM,
{$ENDIF}
FileProcs, CodeCache, DefineTemplates;
type
@ -400,7 +405,11 @@ begin
try
Buf.SaveToStream(ms);
ms.Position:=0;
{$IFDEF NewXMLCfg}
Laz2_XMLRead.ReadXMLFile(ADoc, ms);
Laz_XMLRead.ReadXMLFile(ADoc, ms);
{$ELSE}
{$ENDIF}
exit; // success
finally
ms.Free;
@ -429,7 +438,11 @@ begin
fKeepFileAttributes:=true;
ms:=TMemoryStream.Create;
try
{$IFDEF NewXMLCfg}
Laz2_XMLWrite.WriteXMLFile(ADoc, ms);
{$ELSE}
Laz_XMLWrite.WriteXMLFile(ADoc, ms);
{$ENDIF}
ms.Position:=0;
Buf.LoadFromStream(ms);
if Buf.Save then exit; // success

3338
components/codetools/laz2_dom.pas Normal file
View File

File diff suppressed because it is too large Load Diff

241
components/codetools/laz2_names.inc Normal file
View 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
View File

File diff suppressed because it is too large Load Diff

846
components/codetools/laz2_xmlutils.pas Normal file
View 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
View 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 = '&quot;';
AmpStr = '&amp;';
ltStr = '&lt;';
gtStr = '&gt;';
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('&#x1'+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('&#x1'+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('&#x1'+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.

53
components/codetools/laz_xmlcfg.pas
View File

@ -1,12 +1,7 @@
{
BEWARE !!!
This is a TEMPORARY file.
As soon as it is moved to the fcl, it will be removed.
}
{
$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
Copyright (c) 1999 - 2001 by Sebastian Guenther, sg@freepascal.org
@ -34,9 +29,16 @@ interface
{off $DEFINE MEM_CHECK}
uses
{$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
@ -50,6 +52,9 @@ type
TXMLConfig = class(TComponent)
private
FFilename: String;
{$IFDEF NewXMLCfg}
FReadFlags: TXMLReaderFlags;
{$ENDIF}
procedure SetFilename(const AFilename: String);
protected
doc: TXMLDocument;
@ -93,6 +98,9 @@ type
published
property Filename: String read FFilename write SetFilename;
property Document: TXMLDocument read doc;
{$IFDEF NewXMLCfg}
property ReadFlags: TXMLReaderFlags read FReadFlags write FReadFlags;
{$ENDIF}
end;
@ -100,12 +108,12 @@ type
implementation
uses SysUtils;
constructor TXMLConfig.Create(const AFilename: String);
begin
//DebugLn(['TXMLConfig.Create ',AFilename]);
{$IFDEF NewXMLCfg}
FReadFlags:=[xrfAllowLowerThanInAttributeValue,xrfAllowSpecialCharsInAttributeValue];
{$ENDIF}
inherited Create(nil);
SetFilename(AFilename);
end;
@ -113,6 +121,9 @@ end;
constructor TXMLConfig.CreateClean(const AFilename: String);
begin
//DebugLn(['TXMLConfig.CreateClean ',AFilename]);
{$IFDEF NewXMLCfg}
FReadFlags:=[xrfAllowLowerThanInAttributeValue,xrfAllowSpecialCharsInAttributeValue];
{$ENDIF}
inherited Create(nil);
fDoNotLoadFromFile:=true;
SetFilename(AFilename);
@ -167,14 +178,22 @@ end;
procedure TXMLConfig.ReadFromStream(s: TStream);
begin
FreeDoc;
{$IFDEF NewXMLCfg}
Laz2_XMLRead.ReadXMLFile(Doc,s,ReadFlags);
{$ELSE}
Laz_XMLRead.ReadXMLFile(Doc,s);
{$ENDIF}
if Doc=nil then
Clear;
end;
procedure TXMLConfig.WriteToStream(s: TStream);
begin
{$IFDEF NewXMLCfg}
Laz2_XMLWrite.WriteXMLFile(Doc,s);
{$ELSE}
Laz_XMLWrite.WriteXMLFile(Doc,s);
{$ENDIF}
end;
function TXMLConfig.GetValue(const APath, ADefault: String): String;
@ -445,12 +464,20 @@ end;
procedure TXMLConfig.ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String
);
begin
{$IFDEF NewXMLCfg}
Laz2_XMLRead.ReadXMLFile(ADoc,AFilename,ReadFlags);
{$ELSE}
Laz_XMLRead.ReadXMLFile(ADoc,AFilename);
{$ENDIF}
end;
procedure TXMLConfig.WriteXMLFile(ADoc: TXMLDocument; const AFileName: String);
begin
{$IFDEF NewXMLCfg}
Laz2_XMLWrite.WriteXMLFile(ADoc,AFileName);
{$ELSE}
Laz_XMLWrite.WriteXMLFile(ADoc,AFileName);
{$ENDIF}
end;
procedure TXMLConfig.FreeDoc;
@ -484,7 +511,11 @@ begin
try
ms.Write(fAutoLoadFromSource[1],length(fAutoLoadFromSource));
ms.Position:=0;
{$IFDEF NewXMLCfg}
Laz2_XMLRead.ReadXMLFile(doc,ms,ReadFlags);
{$ELSE}
Laz_XMLRead.ReadXMLFile(doc,ms);
{$ENDIF}
finally
ms.Free;
end;