Vichingo455-RePacks/xtool
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases 1 Wiki Activity

source upload

Browse Source
This commit is contained in:
Razor12911
2022-01-17 22:16:47 +02:00
parent 12936d065b
commit 098e8c48de
1778 changed files with 1206749 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
contrib/fundamentals/XMLParser/flcXML.inc Normal file
View File

@@ -0,0 +1,16 @@
{$INCLUDE ..\flcInclude.inc}
{$IFDEF DEBUG}
{$DEFINE XML_DEBUG}
{$ENDIF}
{$IFDEF DEBUG}
{$IFDEF TEST}
{$DEFINE XML_TEST}
{$ENDIF}
{$ENDIF}
{$IFDEF FREEPASCAL}{$IFDEF DEBUG}
{$WARNINGS OFF}{$HINTS OFF}
{$ENDIF}{$ENDIF}

3059
contrib/fundamentals/XMLParser/flcXMLDocument.pas Normal file
View File

File diff suppressed because it is too large Load Diff

513
contrib/fundamentals/XMLParser/flcXMLFunctions.pas Normal file
View File

@@ -0,0 +1,513 @@
{******************************************************************************}
{ }
{ Library: Fundamentals 5.00 }
{ File name: flcXMLFunctions.pas }
{ File version: 5.10 }
{ Description: XML functions }
{ }
{ Copyright: Copyright (c) 2000-2019, David J Butler }
{ All rights reserved. }
{ Redistribution and use in source and binary forms, with }
{ or without modification, are permitted provided that }
{ the following conditions are met: }
{ Redistributions of source code must retain the above }
{ copyright notice, this list of conditions and the }
{ following disclaimer. }
{ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND }
{ CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED }
{ WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED }
{ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A }
{ PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL }
{ THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, }
{ INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR }
{ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, }
{ PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF }
{ USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) }
{ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER }
{ IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING }
{ NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE }
{ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE }
{ POSSIBILITY OF SUCH DAMAGE. }
{ }
{ Github: https://github.com/fundamentalslib }
{ E-mail: fundamentals.library at gmail.com }
{ }
{ Revision history: }
{ }
{ 2000/05/11 1.01 Created cXML from cInternetStandards. }
{ 2002/02/14 2.02 Fixed bug in xmlValidEncName. Thanks to Thomas Jensen }
{ <tjensen@xs4all.nl> for finding it. }
{ 2002/04/17 2.03 Created cXMLFunctions from cXML. }
{ 2002/04/26 2.04 Unicode support. }
{ 2003/09/07 3.05 Revised for Fundamentals 3. }
{ 2004/02/21 3.06 Added xmlResolveEntityReference function. }
{ 2004/04/01 3.07 Compilable with FreePascal 1.9.2 Win32 i386. }
{ 2005/12/07 4.08 Compilable with FreePascal 2.0.1 Linux i386. }
{ 2019/04/28 5.09 String type changes. }
{ 2019/04/28 5.10 Revised for Fundamentals 5. }
{ }
{******************************************************************************}
{$INCLUDE flcXML.inc}
unit flcXMLFunctions;
interface
uses
{ System }
SysUtils,
{ Fundamentals }
flcStdTypes,
flcUnicodeCodecs,
flcZeroTermStrings;
{ }
{ Constants }
{ }
const
xmlVersion = '1.0';
{ }
{ Exception }
{ }
type
Exml = class(Exception);
{ }
{ Decoding }
{ }
function xmlValidChar(const Ch: AnsiChar): Boolean; overload;
function xmlValidChar(const Ch: UCS4Char): Boolean; overload;
function xmlValidChar(const Ch: WideChar): Boolean; overload;
function xmlIsSpaceChar(const Ch: WideChar): Boolean;
function xmlIsLetter(const Ch: WideChar): Boolean;
function xmlIsDigit(const Ch: WideChar): Boolean;
function xmlIsNameStartChar(const Ch: WideChar): Boolean;
function xmlIsNameChar(const Ch: WideChar): Boolean;
function xmlIsPubidChar(const Ch: WideChar): Boolean;
function xmlValidName(const Text: UnicodeString): Boolean;
const
xmlSpace = [#$20, #$9, #$D, #$A];
function xmlSkipSpace(var P: PWideChar): Boolean;
function xmlSkipEq(var P: PWideChar): Boolean;
function xmlExtractQuotedText(var P: PWideChar; var S: UnicodeString): Boolean;
{ xmlGetEntityEncoding }
{ Buf is a pointer to the first part of an xml entity. It must include }
{ the xml declaration. HeaderSize returns the number of bytes offset in }
{ Buf to the actual xml. }
function xmlGetEntityEncoding(const Buf: Pointer; const BufSize: Integer;
out HeaderSize: Integer): TUnicodeCodecClass;
function xmlResolveEntityReference(const RefName: UnicodeString): WideChar;
{ }
{ Encoding }
{ }
function xmlTag(const Tag: UnicodeString): UnicodeString;
function xmlEndTag(const Tag: UnicodeString): UnicodeString;
function xmlAttrTag(const Tag: UnicodeString;
const Attr: UnicodeString = ''): UnicodeString;
function xmlEmptyTag(const Tag, Attr: UnicodeString): UnicodeString;
procedure xmlSafeTextInPlace(var Txt: UnicodeString);
function xmlSafeText(const Txt: UnicodeString): UnicodeString;
function xmlSpaceIndent(const IndentLength: Integer;
const IndentLevel: Integer): UnicodeString;
function xmlTabIndent(const IndentLevel: Integer): UnicodeString;
function xmlComment(const Comment: UnicodeString): UnicodeString;
{ }
{ Test cases }
{ }
{$IFDEF XML_TEST}
procedure Test;
{$ENDIF}
implementation
uses
{ Fundamentals }
flcUtils,
flcStrings,
flcUnicodeChar;
{ }
{ Decoding }
{ }
{ [2] Char ::= #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | }
{ [#x10000-#x10FFFF] }
function xmlValidChar(const Ch: AnsiChar): Boolean;
begin
Result := Ch in [#$9, #$A, #$D, #$20..#$FF];
end;
function xmlValidChar(const Ch: UCS4Char): Boolean;
begin
if Ch <= $D7FF then
if Ch >= $20 then
Result := True
else
Result := Ch in [$9, $A, $D]
else
if Ch > $10FFFF then
Result := False
else
case Ch of
$D800..$DFFF,
$FFFE..$FFFF : Result := False;
else
Result := True;
end;
end;
function xmlValidChar(const Ch: WideChar): Boolean;
begin
if Ord(Ch) <= $D7FF then
if Ord(Ch) >= $20 then
Result := True
else
Result := Byte(Ord(Ch)) in [$9, $A, $D]
else
case Ch of
#$D800..#$DFFF,
#$FFFE..#$FFFF : Result := False;
else
Result := True;
end;
end;
{ [3] S ::= (#x20 | #x9 | #xD | #xA)+ }
function xmlIsSpaceChar(const Ch: WideChar): Boolean;
begin
if Ord(Ch) > $20 then
Result := False
else
Result := Byte(Ch) in [$20, $09, $0D, $0A];
end;
{ [84] Letter ::= BaseChar | Ideographic }
function xmlIsLetter(const Ch: WideChar): Boolean;
begin
Result := UnicodeIsLetter(Ch);
end;
{ [88] Digit ::= [#x0030-#x0039] | [#x0660-#x0669] | [#x06F0-#x06F9] | }
{ [#x0966-#x096F] | [#x09E6-#x09EF] | [#x0A66-#x0A6F] | }
{ [#x0AE6-#x0AEF] | [#x0B66-#x0B6F] | [#x0BE7-#x0BEF] | }
{ [#x0C66-#x0C6F] | [#x0CE6-#x0CEF] | [#x0D66-#x0D6F] | }
{ [#x0E50-#x0E59] | [#x0ED0-#x0ED9] | [#x0F20-#x0F29] }
function xmlIsDigit(const Ch: WideChar): Boolean;
begin
Result := UnicodeIsDecimalDigit(Ch);
end;
{ [4] NameChar ::= Letter | Digit | '.' | '-' | '_' | ':' | }
{ CombiningChar | Extender }
function xmlIsNameChar(const Ch: WideChar): Boolean;
begin
Result := xmlIsLetter(Ch) or xmlIsDigit(Ch);
if Result then
exit;
case Ch of
'.', '-', '_', ':' : Result := True;
end;
end;
{ [5] Name ::= (Letter | '_' | ':') (NameChar)* }
function xmlIsNameStartChar(const Ch: WideChar): Boolean;
begin
Result := xmlIsLetter(Ch) or (Ch = '_') or (Ch = ':');
end;
{ [13] PubidChar ::= #x20 | #xD | #xA | [a-zA-Z0-9] | }
{ [-'()+,./:=?;!*#@$_%] }
function xmlIsPubidChar(const Ch: WideChar): Boolean;
begin
case Ch of
' ', #$D, #$A, 'A'..'Z', 'a'..'z', '0'..'9',
'-', '''', '(', ')', '+', ',', '.', '/', ':',
'=', '?', ';', '!', '*', '#', '@', '$', '_', '%' :
Result := True;
else
Result := False;
end;
end;
function xmlValidName(const Text: UnicodeString): Boolean;
var P : PWideChar;
L : Integer;
begin
Result := False;
P := Pointer(Text);
L := Length(Text);
if not Assigned(P) or (L = 0) then
exit;
if not xmlIsNameStartChar(P^) then
exit;
Inc(P);
Dec(L);
Result := StrPMatchCharW(P, L, xmlIsNameChar);
end;
{ [3] S ::= (#x20 | #x9 | #xD | #xA)+ }
function xmlSkipSpace(var P: PWideChar): Boolean;
begin
Assert(Assigned(P));
Result := StrZSkipAllW(P, xmlIsSpaceChar) > 0;
end;
{ [25] Eq ::= S? '=' S? }
function xmlSkipEq(var P: PWideChar): Boolean;
var Q : PWideChar;
begin
Q := P;
xmlSkipSpace(Q);
Result := Ord(Q^) = Ord('=');
if not Result then
exit;
Inc(Q);
xmlSkipSpace(Q);
P := Q;
end;
{ [15] Comment ::= '<!--' ((Char - '-') | ('-' (Char - '-')))* '-->' }
function xmlSkipComment(var P: PWideChar): Boolean;
var I : Integer;
begin
Result := StrZMatchStrAsciiBW(P, '<!--', True);
if not Result then
exit;
I := StrZPosBW('-->', P);
Result := I >= 0;
if not Result then
exit;
Inc(P, I + 3);
end;
{ [..] QuotedText ::= ' Text ' | " Text " }
function xmlExtractQuotedText(var P: PWideChar; var S: UnicodeString): Boolean;
begin
Assert(Assigned(P));
Result := StrZExtractQuotedU(P, S, ['''']);
if Result then
exit;
Result := StrZExtractQuotedU(P, S, ['"']);
end;
{ Entity encoding }
{ [23] XMLDecl ::= '<?xml' VersionInfo EncodingDecl? SDDecl? S? '?>' }
{ [24] VersionInfo ::= S 'version' Eq (' VersionNum ' | " VersionNum ") }
{ [26] VersionNum ::= ([a-zA-Z0-9_.:] | '-')+ }
{ [80] EncodingDecl ::= S 'encoding' Eq ('"' EncName '"' | }
{ "'" EncName "'" ) }
function xmlGetEntityEncoding(const Buf: Pointer; const BufSize: Integer;
out HeaderSize: Integer): TUnicodeCodecClass;
var S : UnicodeString;
R : PByteChar;
P, Q : PWideChar;
L : Integer;
begin
R := Buf;
L := BufSize;
// Detect Unicode markings
Result := DetectUTFEncoding(R, L, HeaderSize);
if Assigned(Result) then
exit;
HeaderSize := 0;
Result := TUTF8Codec;
// Check if first character is a likely XML UTF-16 character
if L >= 2 then
begin
P := Pointer(R);
case Ord(P^) of
$0009, $000A, $000D, $0020, $003C : Result := TUTF16LECodec;
$0900, $0A00, $0D00, $2000, $3C00 : Result := TUTF16BECodec;
end;
end;
if L < 16 then
exit;
// Decode
S := EncodingToUTF16U(Result, R, MinInt(L, 4096));
// Locate XML declaration
P := Pointer(S);
while xmlSkipSpace(P) or xmlSkipComment(P) do ;
if not StrZSkipStrBW(P, '<?xml', False) then
exit;
if not xmlSkipSpace(P) then
exit;
// Locate encoding attribute
while (Ord(P^) <> 0) and (P^ <> '>') do
begin
if xmlIsSpaceChar(P^) then
begin
Q := P;
Inc(Q);
if StrZSkipStrBW(Q, 'encoding', False) then
if xmlSkipEq(Q) then
begin
// Extract encoding
if not xmlExtractQuotedText(Q, S) then
S := StrZExtractToU(Q, ['>', #0] + xmlSpace);
StrTrimInPlaceU(S, UnicodeIsWhiteSpace);
if S <> '' then
// Get codec type from encoding name
begin
Result := GetCodecClassByAlias(S);
end;
// Found encoding attribute
exit;
end;
end;
// Next character
Inc(P);
end;
end;
function xmlResolveEntityReference(const RefName: UnicodeString): WideChar;
begin
if StrEqualU(RefName, 'amp', True) then
Result := '&'
else
if StrEqualU(RefName, 'lt', True) then
Result := '<'
else
if StrEqualU(RefName, 'gt', True) then
Result := '>'
else
if StrEqualU(RefName, 'quot', True) then
Result := '"'
else
if StrEqualU(RefName, 'apos', True) then
Result := ''''
else
Result := WideChar(#0);
end;
{ }
{ Encoding }
{ }
function xmlTag(const Tag: UnicodeString): UnicodeString;
begin
Result := '<' + Tag + '>';
end;
function xmlAttrTag(const Tag: UnicodeString; const Attr: UnicodeString): UnicodeString;
begin
if Attr = '' then
Result := xmlTag(Tag)
else
Result := '<' + Tag + ' ' + Attr + '>';
end;
function xmlEndTag(const Tag: UnicodeString): UnicodeString;
begin
Result := '</' + Tag + '>';
end;
function xmlEmptyTag(const Tag, Attr: UnicodeString): UnicodeString;
begin
if Attr = '' then
Result := '<' + Tag + '/>'
else
Result := '<' + Tag + ' ' + Attr + '/>';
end;
procedure xmlSafeTextInPlace(var Txt: UnicodeString);
begin
if PosCharSetU([#0, '&', '''', '"', '>', '<'], Txt) <= 0 then
exit;
Txt := StrReplaceCharStrU(#0, '', Txt);
Txt := StrReplaceCharStrU('&', '&amp;', Txt);
Txt := StrReplaceCharStrU('''', '&apos;', Txt);
Txt := StrReplaceCharStrU('"', '&quot;', Txt);
Txt := StrReplaceCharStrU('>', '&gt;', Txt);
Txt := StrReplaceCharStrU('<', '&lt;', Txt);
end;
function xmlSafeText(const Txt: UnicodeString): UnicodeString;
begin
Result := Txt;
xmlSafeTextInPlace(Result);
end;
function xmlSpaceIndent(const IndentLength: Integer; const IndentLevel: Integer): UnicodeString;
begin
Result := DupCharU(#32, IndentLevel * IndentLength);
end;
function xmlTabIndent(const IndentLevel: Integer): UnicodeString;
begin
Result := DupCharU(#9, IndentLevel);
end;
{ [15] Comment ::= '<!--' ((Char - '-') | ('-' (Char - '-')))* '-->' }
function xmlComment(const Comment: UnicodeString): UnicodeString;
begin
Assert(PosStrU('--', Comment) = 0, 'Invalid sequence in comment');
Result := '<!--' + Comment + '-->';
end;
{ }
{ Test cases }
{ }
{$IFDEF XML_TEST}
{$ASSERTIONS ON}
procedure Test;
var S : RawByteString;
T : UnicodeString;
I : Integer;
begin
Assert(xmlValidChar(WideChar(#32)), 'xmlValidChar');
Assert(xmlValidChar(WideChar(#13)), 'xmlValidChar');
Assert(not xmlValidChar(WideChar(#0)), 'xmlValidChar');
Assert(not xmlValidChar(WideChar(#11)), 'xmlValidChar');
Assert(xmlValidName('_Test_0'), 'xmlValidName');
Assert(not xmlValidName('X '), 'xmlValidName');
Assert(not xmlValidName('X$'), 'xmlValidName');
Assert(not xmlValidName('5X'), 'xmlValidName');
Assert(xmlTag('Test') = '<Test>', 'xmlTag');
Assert(xmlComment('Test') = '<!--Test-->', 'xmlComment');
Assert(xmlSafeText('(abc) [123]') = '(abc) [123]', 'xmlSafeText');
Assert(xmlSafeText('a&<b>') = 'a&amp;&lt;b&gt;', 'xmlSafeText');
Assert(xmlIsSpaceChar(#32), 'xmlIsSpaceChar');
Assert(xmlIsSpaceChar(#13), 'xmlIsSpaceChar');
Assert(not xmlIsSpaceChar('_'), 'xmlIsSpaceChar');
S := '<?xml version="1.0" encoding="ascii">';
Assert(xmlGetEntityEncoding(Pointer(S), Length(S), I) = TUSASCIICodec, 'xmlGetEntityEncoding');
S := ' <?xml attr encoding=ISO-8859-10 > ';
Assert(xmlGetEntityEncoding(Pointer(S), Length(S), I) = TISO8859_10Codec, 'xmlGetEntityEncoding');
T := '<?xml version="1.0">';
Assert(xmlGetEntityEncoding(Pointer(T), Length(T) * SizeOf(WideChar), I) = TUTF16LECodec, 'xmlGetEntityEncoding');
end;
{$ENDIF}
end.

1650
contrib/fundamentals/XMLParser/flcXMLParser.pas Normal file
View File

File diff suppressed because it is too large Load Diff