mirrors/doublecmd
2
0
Fork 0
mirror of https://github.com/doublecmd/doublecmd.git synced 2026-06-21 09:58:13 +00:00
Code Issues Projects Releases Packages Wiki Activity
doublecmd/components/Image32/source/Img32.SVG.Core.pas
Alexander Koblov f333a88e0e FIX: Crash at the start with debug build
2025-03-25 19:57:10 +03:00

3163 lines
87 KiB
ObjectPascal
Raw Blame History

unit Img32.SVG.Core;
(*******************************************************************************
* Author : Angus Johnson *
* Version : 4.7 *
* Date : 12 January 2025 *
* Website : http://www.angusj.com *
* Copyright : Angus Johnson 2019-2025 *
* *
* Purpose : Essential structures and functions to read SVG files *
* *
* License : Use, modification & distribution is subject to *
* Boost Software License Ver 1 *
* http://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
{$I Img32.inc}
uses
SysUtils, Classes, Types, Math, StrUtils,
{$IFDEF XPLAT_GENERICS} Generics.Collections, Generics.Defaults,{$ENDIF}
Img32, Img32.Vector, Img32.Text, Img32.Transform;
{$IFDEF ZEROBASEDSTR}
{$ZEROBASEDSTRINGS OFF}
{$ENDIF}
type
TSvgEncoding = (eUnknown, eUtf8, eUnicodeLE, eUnicodeBE);
TUnitType = (utUnknown, utNumber, utPercent, utEm, utEx, utPixel,
utCm, utMm, utInch, utPt, utPica, utDegree, utRadian);
//////////////////////////////////////////////////////////////////////
// TValue - Structure to store numerics with measurement units.
// See https://www.w3.org/TR/SVG/types.html#InterfaceSVGLength
// and https://www.w3.org/TR/SVG/types.html#InterfaceSVGAngle
//////////////////////////////////////////////////////////////////////
//Unfortunately unit-less values can exhibit ambiguity, especially when their
//values are small (eg < 1.0). These values can be either absolute values or
//relative values (ie relative to the supplied dimension size).
//The 'assumeRelValBelow' parameter (see below) attempts to address this
//ambiguity, such that unit-less values will be assumed to be 'relative' when
//'rawVal' is less than the supplied 'assumeRelValBelow' value.
TValue = {$IFDEF RECORD_METHODS} record {$ELSE} object {$ENDIF}
rawVal : double;
unitType : TUnitType;
procedure Init;
procedure SetValue(val: double; unitTyp: TUnitType = utNumber);
function GetValue(relSize: double; assumeRelValBelow: Double): double;
function GetValueXY(const relSize: TRectD; assumeRelValBelow: Double): double;
function IsValid: Boolean;
function IsRelativeValue(assumeRelValBelow: double): Boolean;
{$IFDEF INLINE} inline; {$ENDIF}
function HasFontUnits: Boolean;
function HasAngleUnits: Boolean;
end;
TValuePt = {$IFDEF RECORD_METHODS} record {$ELSE} object {$ENDIF}
X, Y : TValue;
procedure Init;
function GetPoint(const relSize: double; assumeRelValBelow: Double): TPointD; overload;
function GetPoint(const relSize: TRectD; assumeRelValBelow: Double): TPointD; overload;
function IsValid: Boolean;
end;
TValueRecWH = {$IFDEF RECORD_METHODS} record {$ELSE} object {$ENDIF}
left : TValue;
top : TValue;
width : TValue;
height : TValue;
procedure Init;
function GetRectD(const relSize: TRectD; assumeRelValBelow: Double): TRectD; overload;
function GetRectD(relSize: double; assumeRelValBelow: Double): TRectD; overload;
function GetRectD(relSizeX, relSizeY: double; assumeRelValBelow: Double): TRectD; overload;
function GetRectWH(const relSize: TRectD; assumeRelValBelow: Double): TRectWH;
function IsValid: Boolean;
function IsEmpty: Boolean;
end;
{$IFNDEF UNICODE}
UTF8Char = Char;
PUTF8Char = PChar;
{$ELSE}
{$IF COMPILERVERSION < 31}
UTF8Char = AnsiChar;
PUTF8Char = PAnsiChar;
{$IFEND}
{$ENDIF}
TSvgItalicSyle = (sfsUndefined, sfsNone, sfsItalic);
TFontDecoration = (fdUndefined, fdNone, fdUnderline, fdStrikeThrough);
TSvgTextAlign = (staUndefined, staLeft, staCenter, staRight, staJustify);
TSpacesInText = (sitUndefined, sitIgnore, sitPreserve);
UTF8Strings = array of UTF8String;
TSVGFontInfo = record
family : TFontFamily;
familyNames : UTF8Strings;
size : double;
spacing : double;
spacesInText : TSpacesInText;
textLength : double;
italic : TSvgItalicSyle;
weight : Integer;
align : TSvgTextAlign;
decoration : TFontDecoration;
baseShift : TValue;
end;
//////////////////////////////////////////////////////////////////////
// TClassStylesList: Map that stores CSS selectors with their styles
//////////////////////////////////////////////////////////////////////
PClassStyleListItem = ^TClassStyleListItem;
TClassStyleListItem = record //used internally by TClassStylesList
Hash : Cardinal;
Next : Integer;
Name : UTF8String;
Style : UTF8String;
end;
TClassStylesList = class
private
FNameHash: Cardinal;
FItems: array of TClassStyleListItem;
FBuckets: TArrayOfInteger;
FCount: Integer;
FMod: Cardinal;
procedure Grow(NewCapacity: Integer = -1);
function FindItemIndex(const Name: UTF8String): Integer;
public
procedure Preallocate(AdditionalItemCount: Integer);
procedure AddAppendStyle(const Name, Style: UTF8String);
function GetStyle(const Name: UTF8String): UTF8String;
procedure Clear;
end;
//////////////////////////////////////////////////////////////////////
// TSvgParser and associated classes - a simple parser for SVG xml
//////////////////////////////////////////////////////////////////////
PSvgAttrib = ^TSvgAttrib; //element attribute
TSvgAttrib = record
hash : Cardinal; //hashed name
name : UTF8String;
value : UTF8String;
end;
TSvgParser = class;
TXmlEl = class //base element class
private
{$IFDEF XPLAT_GENERICS}
attribs : TList <PSvgAttrib>;
{$ELSE}
attribs : TList;
{$ENDIF}
function GetAttrib(index: integer): PSvgAttrib;
function GetAttribCount: integer;
public
{$IFDEF XPLAT_GENERICS}
childs : TList<TXmlEl>;
{$ELSE}
childs : TList;
{$ENDIF}
name : UTF8String;
owner : TSvgParser;
hash : Cardinal;
text : UTF8String;
selfClosed : Boolean;
constructor Create(owner: TSvgParser); virtual;
destructor Destroy; override;
procedure Clear; virtual;
function ParseHeader(var c: PUTF8Char; endC: PUTF8Char): Boolean; virtual;
function ParseContent(var c: PUTF8Char; endC: PUTF8Char): Boolean; virtual;
class function ParseAttribName(c, endC: PUTF8Char; attrib: PSvgAttrib): PUTF8Char; {$IFDEF CLASS_STATIC}static;{$ENDIF}
class function ParseAttribValue(c, endC: PUTF8Char; attrib: PSvgAttrib): PUTF8Char; {$IFDEF CLASS_STATIC}static;{$ENDIF}
class function ParseAttribNameAndValue(c, endC: PUTF8Char; attrib: PSvgAttrib): PUTF8Char; {$IFDEF CLASS_STATIC}static;{$ENDIF}
function ParseAttributes(var c: PUTF8Char; endC: PUTF8Char): Boolean; virtual;
procedure ParseStyleAttribute(const style: UTF8String);
property Attrib[index: integer]: PSvgAttrib read GetAttrib;
property AttribCount: integer read GetAttribCount;
end;
TDocTypeEl = class(TXmlEl)
private
function SkipWord(c, endC: PUTF8Char): PUTF8Char;
function ParseEntities(var c, endC: PUTF8Char): Boolean;
public
function ParseAttributes(var c: PUTF8Char; endC: PUTF8Char): Boolean; override;
end;
TSvgXmlEl = class(TXmlEl)
public
constructor Create(owner: TSvgParser); override;
procedure Clear; override;
function ParseHeader(var c: PUTF8Char; endC: PUTF8Char): Boolean; override;
end;
TSvgParser = class
private
svgStream : TMemoryStream;
procedure ParseUtf8Stream;
public
classStyles : TClassStylesList;
xmlHeader : TXmlEl;
docType : TDocTypeEl;
svgTree : TSvgXmlEl;
constructor Create;
destructor Destroy; override;
procedure Clear;
function FindEntity(hash: Cardinal): PSvgAttrib;
function LoadFromFile(const filename: string): Boolean;
function LoadFromStream(stream: TStream): Boolean;
function LoadFromString(const str: string): Boolean;
end;
//////////////////////////////////////////////////////////////////////
// Miscellaneous SVG functions
//////////////////////////////////////////////////////////////////////
//general parsing functions //////////////////////////////////////////
function ParseNextWord(var c: PUTF8Char; endC: PUTF8Char;
out word: UTF8String): Boolean;
function ParseNextWordHash(var c: PUTF8Char; endC: PUTF8Char;
out hash: cardinal): Boolean; overload;
function ParseNextWordHash(c, endC: PUTF8Char): cardinal; overload;
function ParseNextWordExHash(var c: PUTF8Char; endC: PUTF8Char;
out hash: cardinal): Boolean;
function ParseNextNum(var c: PUTF8Char; endC: PUTF8Char;
skipComma: Boolean; out val: double): Boolean;
function ParseNextNumEx(var c: PUTF8Char; endC: PUTF8Char; skipComma: Boolean;
out val: double; out unitType: TUnitType): Boolean;
function GetHash(c: PUTF8Char; len: nativeint): cardinal; overload;
function GetHash(const name: UTF8String): cardinal; overload; {$IFDEF INLINE} inline; {$ENDIF}
function GetHashCaseSensitive(name: PUTF8Char; nameLen: integer): cardinal;
function ExtractRef(const href: UTF8String): UTF8String;
function IsNumPending(var c: PUTF8Char;
endC: PUTF8Char; ignoreComma: Boolean): Boolean;
function UTF8StringToColor32(const value: UTF8String; var color: TColor32): Boolean;
function ScaleDashArray(const dblArray: TArrayOfDouble; scale: double): TArrayOfDouble;
function Match(c: PUTF8Char; const compare: UTF8String): Boolean; overload;
function Match(const compare1, compare2: UTF8String): Boolean; overload;
function PosEx(const subStr: utf8String; const text: Utf8String; startIdx: integer = 1): integer;
procedure ToUTF8String(c, endC: PUTF8Char; var S: UTF8String;
spacesInText: TSpacesInText = sitUndefined);
function TrimMultiSpacesUtf8(const text: Utf8String): Utf8String;
function TrimMultiSpacesUnicode(const text: UnicodeString): UnicodeString;
function ConvertNewlines(const s: UTF8String): UTF8String; overload;
function ConvertNewlines(const s: UnicodeString): UnicodeString; overload;
function StripNewlines(const s: UTF8String): UTF8String; overload;
function StripNewlines(const s: UnicodeString): UnicodeString; overload;
procedure ToAsciiLowerUTF8String(c, endC: PUTF8Char; var S: UTF8String);
procedure ToTrimmedUTF8String(c, endC: PUTF8Char; var S: UTF8String);
function IsSameUTF8String(const S1, S2: UTF8String): Boolean;
//special parsing functions //////////////////////////////////////////
procedure ParseStyleElementContent(const value: UTF8String; stylesList: TClassStylesList);
function ParseTransform(const transform: UTF8String): TMatrixD;
procedure GetSvgFontInfo(const value: UTF8String; var fontInfo: TSVGFontInfo);
function HtmlDecode(const html: UTF8String): UTF8String;
function GetXmlEncoding(memory: Pointer; len: integer): TSvgEncoding;
function ClampRange(val, min, max: double): double;
function SkipBlanks(var c: PUTF8Char; endC: PUTF8Char): Boolean;
function SkipBlanksEx(c: PUTF8Char; endC: PUTF8Char): PUTF8Char; {$IFDEF INLINE} inline; {$ENDIF}
function SkipBlanksAndComma(c, endC: PUTF8Char): PUTF8Char; {$IFDEF INLINE} inline; {$ENDIF}
function GetCommaSeparatedArray(const str: UTF8String): UTF8Strings;
function TrimQuotes(const str: UTF8String): UTF8String;
procedure ConvertUnicodeToUtf8(memStream: TMemoryStream);
function GetScale(src, dst: double): double;
function GetScaleForBestFit(srcW, srcH, dstW, dstH: double): double;
function Base64Decode(const str: PAnsiChar; len: integer; memStream: TMemoryStream): Boolean;
type
TSetOfUTF8Char = set of UTF8Char;
function CharInSet(chr: UTF8Char; const chrs: TSetOfUTF8Char): Boolean;
function DecodeUtf8ToUnicode(const utf8: UTF8String): UnicodeString;
const
clInvalid = $00010001;
clCurrent = $00010002;
sqrt2 = 1.4142135623731;
quote = '''';
dquote = '"';
space = #32;
comma = ',';
SvgDecimalSeparator = '.'; //do not localize
{$I Img32.SVG.HashConsts.inc}
var
LowerCaseTable : array[#0..#$FF] of UTF8Char;
implementation
//------------------------------------------------------------------------------
// Color Constant HashMap
//------------------------------------------------------------------------------
type
PColorConst = ^TColorConst;
TColorConst = record
ColorName : UTF8String;
ColorValue: TColor32;
end;
PPColorConstMapItem = ^PColorConstMapItem;
PColorConstMapItem = ^TColorConstMapItem;
TColorConstMapItem = record
Hash: Cardinal;
Next: PColorConstMapItem;
Data: PColorConst;
end;
PColorConstMapItemArray = ^TColorConstMapItemArray;
TColorConstMapItemArray = array[0..MaxInt div SizeOf(TColorConstMapItem) - 1] of TColorConstMapItem;
TColorConstList = class(TObject)
private
FItems: array of TColorConstMapItem;
FBuckets: array of PColorConstMapItem;
FCount: Integer;
FMod: Cardinal;
public
constructor Create(Colors: PColorConst; Count: Integer);
function GetColorValue(const ColorName: UTF8String; var Color: TColor32): Boolean;
end;
var
ColorConstList : TColorConstList;
const
buffSize = 8;
//include hashed html entity constants
{$I Img32.SVG.HtmlHashConsts.inc}
//------------------------------------------------------------------------------
// Base64 (MIME) Encode & Decode and other encoding functions ...
//------------------------------------------------------------------------------
type
PFourChars = ^TFourChars;
TFourChars = record
c1: ansichar;
c2: ansichar;
c3: ansichar;
c4: ansichar;
end;
function Chr64ToVal(c: ansiChar): integer; {$IFDEF INLINE} inline; {$ENDIF}
begin
case c of
'+': result := 62;
'/': result := 63;
'0'..'9': result := ord(c) + 4;
'A'..'Z': result := ord(c) -65;
'a'..'z': result := ord(c) -71;
else Raise Exception.Create('Corrupted MIME encoded text');
end;
end;
//------------------------------------------------------------------------------
function FrstChr(c: PFourChars): ansichar; {$IFDEF INLINE} inline; {$ENDIF}
begin
result := ansichar(Chr64ToVal(c.c1) shl 2 or Chr64ToVal(c.c2) shr 4);
end;
//------------------------------------------------------------------------------
function ScndChr(c: PFourChars): ansichar; {$IFDEF INLINE} inline; {$ENDIF}
begin
result := ansichar(Chr64ToVal(c.c2) shl 4 or Chr64ToVal(c.c3) shr 2);
end;
//------------------------------------------------------------------------------
function ThrdChr(c: PFourChars): ansichar; {$IFDEF INLINE} inline; {$ENDIF}
begin
result := ansichar( Chr64ToVal(c.c3) shl 6 or Chr64ToVal(c.c4) );
end;
//------------------------------------------------------------------------------
function Base64Decode(const str: PAnsiChar; len: integer; memStream: TMemoryStream): Boolean;
var
i, j, extra: integer;
Chars4: PFourChars;
dst: PAnsiChar;
begin
result := false;
if (len = 0) or (len mod 4 > 0) or not Assigned(memStream) then exit;
if str[len-2] = '=' then extra := 2
else if str[len-1] = '=' then extra := 1
else extra := 0;
memStream.SetSize(LongInt((len div 4 * 3) - extra));
dst := memStream.Memory;
Chars4 := @str[0];
i := 0;
try
for j := 1 to (len div 4) -1 do
begin
dst[i] := FrstChr(Chars4);
dst[i+1] := ScndChr(Chars4);
dst[i+2] := ThrdChr(Chars4);
inc(pbyte(Chars4),4);
inc(i,3);
end;
dst[i] := FrstChr(Chars4);
if extra < 2 then dst[i+1] := ScndChr(Chars4);
if extra < 1 then dst[i+2] := ThrdChr(Chars4);
except
Exit;
end;
Result := true;
end;
//------------------------------------------------------------------------------
// Miscellaneous functions ...
//------------------------------------------------------------------------------
function NewSvgAttrib(): PSvgAttrib; {$IFDEF INLINE} inline; {$ENDIF}
begin
// New(Result) uses RTTI to initialize the UTF8String fields to nil.
// By allocating zero'ed memory we can achieve that much faster.
Result := AllocMem(SizeOf(TSvgAttrib));
end;
//------------------------------------------------------------------------------
procedure DisposeSvgAttrib(attrib: PSvgAttrib); {$IFDEF INLINE} inline; {$ENDIF}
begin
// Dispose(Result) uses RTTI to set the UTF8String fields to nil.
// By clearing them outself we can achieve that much faster.
attrib.name := '';
attrib.value := '';
FreeMem(attrib);
end;
//------------------------------------------------------------------------------
function GetScale(src, dst: double): double;
begin
Result := dst / src;
if (SameValue(Result, 1, 0.00001)) then Result := 1;
end;
//------------------------------------------------------------------------------
function GetScaleForBestFit(srcW, srcH, dstW, dstH: double): double;
var
sx,sy: double;
begin
sx := dstW / srcW;
sy := dstH / srcH;
if sy < sx then sx := sy;
if (SameValue(sx, 1, 0.00001)) then
Result := 1 else
Result := sx;
end;
//------------------------------------------------------------------------------
function ClampRange(val, min, max: double): double;
{$IFDEF INLINE} inline; {$ENDIF}
begin
if val <= min then Result := min
else if val >= max then Result := max
else Result := val;
end;
//------------------------------------------------------------------------------
function IsSameAsciiUTF8String(const S1, S2: UTF8String): Boolean;
var
Len: Integer;
I: Integer;
Ch1, Ch2: UTF8Char;
begin
Len := Length(S1);
Result := Len = Length(S2);
if Result then
begin
Result := False;
I := 1;
while True do
begin
if I > Len then
Break;
Ch1 := S1[I];
Ch2 := S2[I];
if Ch1 = Ch2 then
begin
Inc(I);
Continue;
end;
case Ch1 of
'A'..'Z', 'a'..'z':
ch1 := UTF8Char(Ord(ch1) xor $20); // toggle upper/lower
end;
if Ch1 <> Ch2 then
Exit;
Inc(I);
end;
Result := True;
end;
end;
//------------------------------------------------------------------------------
function IsSameUTF8StringSlow(const S1, S2: UTF8String): Boolean;
begin
Result := AnsiSameText(string(S1), string(S2));
end;
//------------------------------------------------------------------------------
function IsSameUTF8String(const S1, S2: UTF8String): Boolean;
var
Len: Integer;
I: Integer;
Ch1, Ch2: UTF8Char;
begin
Len := Length(S1);
Result := Len = Length(S2);
if Result then
begin
Result := False;
I := 1;
Ch1 := #0;
Ch2 := #0;
while True do
begin
if I > Len then
Break;
Ch1 := S1[I];
Ch2 := S2[I];
if Ch1 = Ch2 then
begin
Inc(I);
Continue;
end;
case Ch1 of
'A'..'Z', 'a'..'z':
ch1 := UTF8Char(Ord(ch1) xor $20); // toggle upper/lower
end;
if Ch1 <> Ch2 then
Break;
Inc(I);
end;
if Ch1 = Ch2 then
Result := True
else if (Ord(Ch1) or Ord(Ch2)) and $80 <> 0 then // we found non-matching, non-ASCII characters
Result := IsSameUTF8StringSlow(S1, S2);
end;
end;
//------------------------------------------------------------------------------
function CharInSet(chr: UTF8Char; const chrs: TSetOfUTF8Char): Boolean;
begin
Result := chr in chrs;
end;
//------------------------------------------------------------------------------
function Match(c: PUTF8Char; const compare: UTF8String): Boolean;
var
i: integer;
begin
Result := false;
for i := 1 to Length(compare) do
begin
if LowerCaseTable[c[i - 1]] <> compare[i] then Exit;
end;
Result := true;
end;
//------------------------------------------------------------------------------
function Match(const compare1, compare2: UTF8String): Boolean;
var
i, len: integer;
c1, c2: PUTF8Char;
begin
Result := false;
len := Length(compare1);
if len <> Length(compare2) then Exit;
c1 := @compare1[1]; c2 := @compare2[1];
for i := 1 to len do
begin
if LowerCaseTable[c1[i - 1]] <> LowerCaseTable[c2[i - 1]] then Exit;
end;
Result := true;
end;
//------------------------------------------------------------------------------
function Split(const str: UTF8String): UTF8Strings;
var
i,j,k, spcCnt, len: integer;
begin
spcCnt := 0;
i := 1;
len := Length(str);
while (len > 0) and (str[len] <= space) do dec(len);
while (i <= len) and (str[i] <= space) do inc(i);
for j := i + 1 to len do
if (str[j] <= space) and (str[j -1] > space) then inc(spcCnt);
SetLength(Result, spcCnt +1);
for k := 0 to spcCnt do
begin
j := i;
while (j <= len) and (str[j] > space) do inc(j);
SetLength(Result[k], j -i);
if j > i then
Move(str[i], Result[k][1], j -i);
while (j <= len) and (str[j] <= space) do inc(j);
i := j;
end;
end;
//------------------------------------------------------------------------------
function TrimQuotes(const str: UTF8String): UTF8String;
var
i, len: integer;
savedQuote: UTF8Char;
begin
len := Length(str);
i := 1;
while (i < len) and (str[i] <= space) do inc(i);
if (i < len) and (str[i] in [quote, dquote]) then
begin
savedQuote := str[i];
inc(i);
while (len > i) and (str[len] <= space) do dec(len);
if (len = i) or (str[len] <> savedQuote) then
Result := str else // oops!
Result := Copy(str, i, len - i);
end
else
Result := str
end;
//------------------------------------------------------------------------------
function GetCommaSeparatedArray(const str: UTF8String): UTF8Strings;
var
i,j,k, cnt, len: integer;
begin
// precondition: commas CANNOT be embedded
len := Length(str);
cnt := 1;
for i := 1 to len do
if (str[i] = comma) then inc(cnt);
SetLength(Result, cnt);
j := 0;
k := 1;
for i := 1 to len do
begin
if (str[i] <> comma) then Continue;
Result[j] := TrimQuotes(Copy(str, k, i-k));
inc(j);
k := i + 1;
end;
if len >= k then
Result[j] := TrimQuotes(Copy(str, k, len-k +1));
end;
//------------------------------------------------------------------------------
function GetXmlEncoding(memory: Pointer; len: integer): TSvgEncoding;
var
p, p1: PUTF8Char;
begin
Result := eUnknown;
if (len < 4) or not Assigned(memory) then Exit;
p := PUTF8Char(memory);
p1 := (p + 1);
case p^ of
#$EF: if (p1^ = #$BB) then
if ((p +2)^ = #$BF) then
Result := eUtf8 else
Exit;
#$FF: if (p1^ = #$FE) or (p1^ = #0) then
Result := eUnicodeLE;
#$FE: if (p1^ = #$FF) then
Result := eUnicodeBE;
end;
end;
//------------------------------------------------------------------------------
function SkipBlanks(var c: PUTF8Char; endC: PUTF8Char): Boolean;
var
cc: PUTF8Char;
begin
cc := c;
if (cc < endC) and (cc^ <= space) then
begin
inc(cc);
while (cc < endC) and (cc^ <= space) do inc(cc);
c := cc;
end;
Result := (cc < endC);
end;
//------------------------------------------------------------------------------
function SkipBlanksEx(c: PUTF8Char; endC: PUTF8Char): PUTF8Char;
begin
while (c < endC) and (c^ <= space) do inc(c);
Result := c;
end;
//------------------------------------------------------------------------------
function SkipBlanksAndComma(c, endC: PUTF8Char): PUTF8Char;
begin
Result := SkipBlanksEx(c, endC);
if (Result >= endC) or (Result^ <> ',') then Exit;
Result := SkipBlanksEx(Result + 1, endC);
end;
//------------------------------------------------------------------------------
function SkipStyleBlanks(c, endC: PUTF8Char): PUTF8Char;
var
inComment: Boolean;
ch: UTF8Char;
begin
//style content may include multi-line comment blocks
inComment := false;
while (c < endC) do
begin
ch := c^;
if inComment then
begin
if (ch = '*') and ((c +1)^ = '/') then
begin
inComment := false;
inc(c);
end;
end
else if (ch > space) then
begin
inComment := (ch = '/') and ((c +1)^ = '*');
if not inComment then break;
inc(c);
end;
inc(c);
end;
Result := c;
end;
//------------------------------------------------------------------------------
function IsDigit(c: UTF8Char): Boolean; {$IFDEF INLINE} inline; {$ENDIF}
begin
case c of
'0'..'9': Result := True;
else Result := False;
end;
end;
//------------------------------------------------------------------------------
function IsQuoteChar(c: UTF8Char): Boolean; {$IFDEF INLINE} inline; {$ENDIF}
begin
Result := (c = quote) or (c = dquote);
end;
//------------------------------------------------------------------------------
function IsAlpha(c: UTF8Char): Boolean; {$IFDEF INLINE} inline; {$ENDIF}
begin
case c of
'A'..'Z', 'a'..'z': Result := True;
else Result := False;
end;
end;
//------------------------------------------------------------------------------
function ParseStyleNameLen(c, endC: PUTF8Char): PUTF8Char;
var
c2: PUTF8Char;
begin
Result := c;
//nb: style names may start with a hyphen
c2 := Result;
if (c2^ = '-') then inc(c2);
if not IsAlpha(c2^) then Exit;
Result := c2 + 1;
while Result < endC do
begin
case Result^ of
'0'..'9', 'A'..'Z', 'a'..'z', '-': inc(Result);
else break;
end;
end;
end;
//------------------------------------------------------------------------------
function ParseNextWord(var c: PUTF8Char; endC: PUTF8Char; out word: UTF8String): Boolean;
var
c2, cc: PUTF8Char;
begin
cc := SkipBlanksAndComma(c, endC);
if cc >= endC then
begin
c := cc;
Result := False;
Exit;
end;
c2 := cc;
while cc < endC do
begin
case cc^ of
'A'..'Z', 'a'..'z': inc(cc);
else break;
end;
end;
c := cc;
ToUTF8String(c2, cc, word);
Result := True;
end;
//------------------------------------------------------------------------------
function ParseNextWordHash(var c: PUTF8Char; endC: PUTF8Char; out hash: cardinal): Boolean;
var
c2, cc: PUTF8Char;
begin
cc := SkipBlanksAndComma(c, endC);
if cc >= endC then
begin
c := cc;
hash := 0;
Result := False;
Exit;
end;
c2 := cc;
while cc < endC do
begin
case cc^ of
'A'..'Z', 'a'..'z': inc(cc);
else break;
end;
end;
c := cc;
hash := GetHash(c2, cc - c2);
Result := True;
end;
//------------------------------------------------------------------------------
function ParseNextWordHash(c, endC: PUTF8Char): cardinal;
var
c2: PUTF8Char;
begin
c := SkipBlanksAndComma(c, endC);
if c >= endC then
begin
Result := 0;
Exit;
end;
c2 := c;
while c < endC do
begin
case c^ of
'A'..'Z', 'a'..'z': inc(c);
else break;
end;
end;
Result := GetHash(c2, c - c2);
end;
//------------------------------------------------------------------------------
function ParseNextWordExHash(var c: PUTF8Char; endC: PUTF8Char;
out hash: cardinal): Boolean;
var
c2, cc: PUTF8Char;
begin
cc := SkipBlanksAndComma(c, endC);
if cc >= endC then
begin
c := cc;
hash := 0;
Result := False;
Exit;
end;
if cc^ = quote then
begin
inc(c);
c2 := cc;
while (cc < endC) and (cc^ <> quote) do inc(cc);
hash := GetHash(c2, cc - c2);
inc(cc);
end else
begin
if not IsAlpha(cc^) then
begin
hash := 0;
Result := False;
Exit;
end;
c2 := cc;
inc(cc);
while cc < endC do
case cc^ of
'A'..'Z', 'a'..'z', '-', '_': inc(cc);
else break;
end;
hash := GetHash(c2, cc - c2);
end;
c := cc;
Result := True;
end;
//------------------------------------------------------------------------------
function ParseNameLength(c: PUTF8Char; endC: PUTF8Char): PUTF8Char;
begin
inc(c);
while c < endC do
begin
case c^ of
'0'..'9', 'A'..'Z', 'a'..'z', '_', ':', '-': inc(c);
else break;
end;
end;
Result := c;
end;
//------------------------------------------------------------------------------
{$PUSH}{$Q-}{$R-}
function GetHash(c: PUTF8Char; len: nativeint): cardinal;
var
i: integer;
begin
//https://en.wikipedia.org/wiki/Jenkins_hash_function
Result := 0;
if c = nil then Exit;
for i := 1 to len do
begin
Result := (Result + Ord(LowerCaseTable[c^]));
Result := Result + (Result shl 10);
Result := Result xor (Result shr 6);
inc(c);
end;
Result := Result + (Result shl 3);
Result := Result xor (Result shr 11);
Result := Result + (Result shl 15);
end;
{$POP}
//------------------------------------------------------------------------------
function GetHash(const name: UTF8String): cardinal;
begin
// skip function call by directly casting it to Pointer
Result := GetHash(PUTF8Char(Pointer(name)), Length(name));
end;
//------------------------------------------------------------------------------
{$PUSH}{$Q-}{$R-}
function GetHashCaseSensitive(name: PUTF8Char; nameLen: integer): cardinal;
var
i: integer;
begin
Result := 0;
for i := 1 to nameLen do
begin
Result := (Result + Ord(name^));
Result := Result + (Result shl 10);
Result := Result xor (Result shr 6);
inc(name);
end;
Result := Result + (Result shl 3);
Result := Result xor (Result shr 11);
Result := Result + (Result shl 15);
end;
{$POP}
//------------------------------------------------------------------------------
function ParseNextWordHashed(var c: PUTF8Char; endC: PUTF8Char): cardinal;
var
c2: PUTF8Char;
len: integer;
begin
c2 := c;
c := ParseNameLength(c2, endC);
len := c - c2;
if len <= 0 then Result := 0
else Result := GetHash(c2, len);
end;
//------------------------------------------------------------------------------
function ParseExpDigits(c, endC: PUTF8Char; out val: Integer): PUTF8Char; {$IFDEF INLINE} inline; {$ENDIF}
var
v32: Cardinal;
Digit: Integer;
begin
Result := c;
v32 := 0;
while Result < endC do
begin
Digit := Integer(Ord(Result^)) - Ord('0');
if Cardinal(Digit) >= 10 then break;
{$IFDEF FPC} // Something Delphi can optimize but FPC can't (yet?)
v32 := (v32 shl 3) + (v32 shl 1) + Cardinal(Digit); // Delphi's code is even better than this
{$ELSE}
v32 := v32 * 10 + Cardinal(Digit);
{$ENDIF FPC}
inc(Result);
end;
val := v32;
end;
//------------------------------------------------------------------------------
function ParseDigitsToDouble(c, endC: PUTF8Char; out val: double): PUTF8Char;
var
v32: Cardinal;
v64: Int64;
Digit: Integer;
blockEndC: PUTF8Char;
begin
// skip leading zeros
while (c < endC) and (c^ = '0') do inc(c);
// Use Int32 first as it is fast for 64bit and 32bit CPUs
Result := c;
v32 := 0;
blockEndC := c + 9; // log10(2^31) = 9.33
if blockEndC > endC then
blockEndC := endC;
while Result < blockEndC do
begin
Digit := Integer(Ord(Result^)) - Ord('0');
if Cardinal(Digit) >= 10 then break;
{$IFDEF FPC} // Something Delphi can optimize but FPC can't (yet?)
v32 := (v32 shl 3) + (v32 shl 1) + Cardinal(Digit);
{$ELSE}
v32 := v32 * 10 + Cardinal(Digit);
{$ENDIF FPC}
inc(Result);
end;
if (Result < endC) and (Result >= blockEndC) then
begin
v64 := v32;
blockEndC := c + 18; // log10(2^63) = 18.96
if blockEndC > endC then
blockEndC := endC;
while Result < blockEndC do
begin
Digit := Integer(Ord(Result^)) - Ord('0');
if Cardinal(Digit) >= 10 then break;
{$IF (SizeOf(Pointer) = 4) or defined(FPC)} // neither Delphi 32bit nor FPC can optimize this
v64 := (v64 shl 3) + (v64 shl 1) + Cardinal(Digit);
{$ELSE}
v64 := v64 * 10 + Cardinal(Digit);
{$IFEND}
inc(Result);
end;
val := v64;
// Use Double for the remaining digits and loose precision (we are beyong 16 digits anyway)
if (Result < endC) and (Result >= blockEndC) then
begin
while Result < endC do
begin
Digit := Integer(Ord(Result^)) - Ord('0');
if Cardinal(Digit) >= 10 then break;
val := val * 10 + Digit;
inc(Result);
end;
end;
end
else
val := v32;
end;
//------------------------------------------------------------------------------
function ParseNextNumEx(var c: PUTF8Char; endC: PUTF8Char; skipComma: Boolean;
out val: double; out unitType: TUnitType): Boolean;
const
Power10: array[0..18] of Double = (
1E0, 1E1, 1E2, 1E3, 1E4, 1E5, 1E6, 1E7, 1E8, 1E9,
1E10, 1E11, 1E12, 1E13, 1E14, 1E15, 1E16, 1E17, 1E18
);
Power10Reciprocal: array[0..18] of Double = (
1/1E0, 1/1E1, 1/1E2, 1/1E3, 1/1E4, 1/1E5, 1/1E6, 1/1E7, 1/1E8, 1/1E9,
1/1E10, 1/1E11, 1/1E12, 1/1E13, 1/1E14, 1/1E15, 1/1E16, 1/1E17, 1/1E18
);
var
exp: integer;
isNeg, expIsNeg: Boolean;
start, decStart, cc: PUTF8Char;
decimals: Double;
begin
Result := false;
unitType := utNumber;
cc := c;
//skip white space +/- single comma
if skipComma then
begin
while (cc < endC) and (cc^ <= space) do inc(cc);
if (cc^ = ',') then inc(cc);
end;
while (cc < endC) and (cc^ <= space) do inc(cc);
if (cc = endC) then
begin
c := cc;
Exit;
end;
exp := Invalid; expIsNeg := false;
isNeg := cc^ = '-';
if isNeg then inc(cc);
start := cc;
// Use fast parsing
cc := ParseDigitsToDouble(cc, endC, val);
if cc < endC then
begin
// Decimals
if Ord(cc^) = Ord(SvgDecimalSeparator) then
begin
inc(cc);
decStart := cc;
cc := ParseDigitsToDouble(cc, endC, decimals);
if cc > decStart then
begin
if cc - decStart <= 18 then
val := val + (decimals * Power10Reciprocal[(cc - decStart)])
else
val := val + (decimals * Power(10, -(cc - decStart)))
end;
end;
// Exponent
if (cc < endC) and ((cc^ = 'e') or (cc^ = 'E')) then
begin
case (cc+1)^ of
'-', '0'..'9':
begin
inc(cc);
if cc^ = '-' then
begin
expIsNeg := true;
inc(cc);
end;
cc := ParseExpDigits(cc, endC, exp);
end;
end;
end;
end;
Result := cc > start;
if not Result then
begin
c := cc;
Exit;
end;
if isNeg then val := -val;
if IsValid(exp) then
begin
if exp <= 18 then
begin
if expIsNeg then
val := val * Power10Reciprocal[exp] else
val := val * Power10[exp];
end
else
begin
if expIsNeg then
val := val * Power(10, -exp) else
val := val * Power(10, exp);
end;
end;
//https://oreillymedia.github.io/Using_SVG/guide/units.html
case cc^ of
'%':
begin
inc(cc);
unitType := utPercent;
end;
'c': //convert cm to pixels
if ((cc+1)^ = 'm') then
begin
inc(cc, 2);
unitType := utCm;
end;
'd': //ignore deg
if ((cc+1)^ = 'e') and ((cc+2)^ = 'g') then
begin
inc(cc, 3);
unitType := utDegree;
end;
'e': //convert cm to pixels
if ((cc+1)^ = 'm') then
begin
inc(cc, 2);
unitType := utEm;
end
else if ((cc+1)^ = 'x') then
begin
inc(cc, 2);
unitType := utEx;
end;
'i': //convert inchs to pixels
if ((cc+1)^ = 'n') then
begin
inc(cc, 2);
unitType := utInch;
end;
'm': //convert mm to pixels
if ((cc+1)^ = 'm') then
begin
inc(cc, 2);
unitType := utMm;
end;
'p':
case (cc+1)^ of
'c':
begin
inc(cc, 2);
unitType := utPica;
end;
't':
begin
inc(cc, 2);
unitType := utPt;
end;
'x':
begin
inc(cc, 2);
unitType := utPixel;
end;
end;
'r': //convert radian angles to degrees
if Match(cc, 'rad') then
begin
inc(cc, 3);
unitType := utRadian;
end;
end;
c := cc;
end;
//------------------------------------------------------------------------------
function ParseNextNum(var c: PUTF8Char; endC: PUTF8Char;
skipComma: Boolean; out val: double): Boolean;
var
tmp: TValue;
begin
tmp.Init;
Result := ParseNextNumEx(c, endC, skipComma, tmp.rawVal, tmp.unitType);
val := tmp.GetValue(1, 1);
end;
//------------------------------------------------------------------------------
function ExtractRef(const href: UTF8String): UTF8String; {$IFDEF INLINE} inline; {$ENDIF}
var
c, c2, endC: PUTF8Char;
begin
c := PUTF8Char(href);
endC := c + Length(href);
if Match(c, 'url(') then
begin
inc(c, 4);
dec(endC); // avoid trailing ')'
end;
if c^ = '#' then inc(c);
c2 := c;
while (c < endC) and (c^ <> ')') do inc(c);
ToUTF8String(c2, c, Result);
end;
//------------------------------------------------------------------------------
function ParseNextChar(var c: PUTF8Char; endC: PUTF8Char): UTF8Char;
var
cc: PUTF8Char;
begin
cc := SkipBlanksEx(c, endC);
if cc >= endC then
Result := #0
else
begin
Result := cc^;
c := cc + 1;
end;
end;
//------------------------------------------------------------------------------
procedure ToTrimmedUTF8String(c, endC: PUTF8Char; var S: UTF8String);
var
len: integer;
begin
// trim left
while (c < endC) and (c^ <= space) do Inc(c);
// trim right
while (endC > c) and (endC[-1] <= space) do Dec(endC);
len := endC - c;
SetLength(S, len);
if len = 0 then Exit;
Move(c^, PUTF8Char(S)^, len * SizeOf(UTF8Char));
end;
//------------------------------------------------------------------------------
function PosEx(const subStr: UTF8String; const text: Utf8String; startIdx: integer): integer;
var
i, maxI, len, subStrLen: integer;
begin
len := Length(Text);
subStrLen := Length(subStr);
maxI := len - subStrLen +1;
for i := Max(1, startIdx) to maxI do
begin
if (text[i] <> subStr[1]) or
not CompareMem(@text[i], @subStr[1], subStrLen) then Continue;
Result := i;
Exit;
end;
Result := 0;
end;
//------------------------------------------------------------------------------
function ReversePosEx(utf8: utf8Char;
const text: Utf8String; startIdx: integer): integer; overload;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result := Max(0, Min(Length(text), startidx));
while (Result > 0) and (text[Result] <> utf8) do Dec(Result);
end;
//------------------------------------------------------------------------------
function TrimMultiSpacesUtf8(const text: Utf8String): Utf8String;
var
i, len: integer;
begin
Result := text;
len := Length(Result);
for i := 1 to len do
if Result[i] < #32 then Result[i] := #32;
i := ReversePosEx(space, Result, len);
while i > 1 do
begin
Dec(i);
while (i > 0) and (Result[i] = space) do
begin
Delete(Result, i, 1);
Dec(i);
end;
i := ReversePosEx(space, Result, i);
end;
end;
//------------------------------------------------------------------------------
function ReversePosEx(c: WideChar;
const text: UnicodeString; startIdx: integer): integer; overload;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result := Max(0, Min(Length(text), startidx));
while (Result > 0) and (text[Result] <> c) do Dec(Result);
end;
//------------------------------------------------------------------------------
function TrimMultiSpacesUnicode(const text: UnicodeString): UnicodeString;
var
i, len: integer;
begin
Result := text;
len := Length(Result);
for i := 1 to len do
if Result[i] < #32 then Result[i] := #32;
i := ReversePosEx(space, Result, len);
while i > 1 do
begin
Dec(i);
while (i > 0) and (Result[i] = space) do
begin
Delete(Result, i, 1);
Dec(i);
end;
i := ReversePosEx(space, Result, i);
end;
end;
//------------------------------------------------------------------------------
function StripNewlines(const s: UTF8String): UTF8String;
var
i: integer;
begin
Result := s;
i := Length(Result);
while i > 0 do
begin
if Result[i] < space then Delete(Result, i, 1);
Dec(i);
end;
end;
//------------------------------------------------------------------------------
function StripNewlines(const s: UnicodeString): UnicodeString;
var
i: integer;
begin
Result := s;
i := Length(Result);
while i > 0 do
begin
if Result[i] < space then Delete(Result, i, 1);
Dec(i);
end;
end;
//------------------------------------------------------------------------------
function ConvertNewlines(const s: UTF8String): UTF8String; overload;
var
i: integer;
begin
Result := s;
i := Length(Result);
while i > 0 do
begin
if Result[i] < space then
begin
if Result[i] = #10 then
Result[i] := space else
Delete(Result, i, 1);
end;
Dec(i);
end;
end;
//------------------------------------------------------------------------------
function ConvertNewlines(const s: UnicodeString): UnicodeString; overload;
var
i: integer;
begin
Result := s;
i := Length(Result);
while i > 0 do
begin
if Result[i] < space then
begin
if Result[i] = #10 then
Result[i] := space else
Delete(Result, i, 1);
end;
Dec(i);
end;
end;
//------------------------------------------------------------------------------
procedure ToUTF8String(c, endC: PUTF8Char;
var S: UTF8String; spacesInText: TSpacesInText);
var
len: integer;
begin
len := endC - c;
SetLength(S, len);
if len = 0 then Exit;
Move(c^, PUTF8Char(S)^, len * SizeOf(UTF8Char));
if spacesInText <> sitPreserve then
S := TrimMultiSpacesUtf8(S);
S := ConvertNewlines(S);
end;
//------------------------------------------------------------------------------
procedure ToAsciiLowerUTF8String(c, endC: PUTF8Char; var S: UTF8String);
// Reads a UTF8String and converts all upper case 'A'..'Z' to lower case 'a'..'z'
var
len: integer;
p: PUTF8Char;
ch: UTF8Char;
begin
len := endC - c;
SetLength(S, len);
if len = 0 then Exit;
// Use a pointer arithmetic trick to run forward by using a negative index
p := PUTF8Char(S) + len;
len := -len;
while len < 0 do
begin
ch := endC[len];
case ch of
'A'..'Z':
ch := UTF8Char(Byte(ch) or $20);
end;
p[len] := ch;
inc(len);
end;
end;
//------------------------------------------------------------------------------
function IsKnownEntity(owner: TSvgParser;
var c: PUTF8Char; endC: PUTF8Char; out entity: PSvgAttrib): boolean;
var
c2, c3: PUTF8Char;
begin
inc(c); //skip ampersand.
c2 := c; c3 := c;
c3 := ParseNameLength(c3, endC);
entity := owner.FindEntity(GetHash(c2, c3 - c2));
Result := (c3^ = ';') and Assigned(entity);
//nb: increments 'c' only if the entity is found.
if Result then c := c3 +1 else dec(c);
end;
//------------------------------------------------------------------------------
function ParseQuotedString(var c: PUTF8Char; endC: PUTF8Char;
out quotStr: UTF8String): Boolean;
var
quote: UTF8Char;
c2: PUTF8Char;
begin
quote := c^;
inc(c);
c2 := c;
while (c < endC) and (c^ <> quote) do inc(c);
Result := (c < endC);
if not Result then Exit;
ToUTF8String(c2, c, quotStr);
inc(c);
end;
//------------------------------------------------------------------------------
function IsNumPending(var c: PUTF8Char;
endC: PUTF8Char; ignoreComma: Boolean): Boolean;
var
c2: PUTF8Char;
begin
Result := false;
//skip white space +/- single comma
if ignoreComma then
begin
while (c < endC) and (c^ <= space) do inc(c);
if (c^ = ',') then inc(c);
end;
while (c < endC) and (c^ <= ' ') do inc(c);
if (c = endC) then Exit;
c2 := c;
if (c2^ = '-') then inc(c2);
if (c2^ = SvgDecimalSeparator) then inc(c2);
Result := (c2 < endC) and IsDigit(c2^);
end;
//------------------------------------------------------------------------------
function ParseTransform(const transform: UTF8String): TMatrixD;
var
i: integer;
c, endC: PUTF8Char;
c2: UTF8Char;
word: UTF8String;
values: array[0..5] of double;
mat: TMatrixD;
begin
c := PUTF8Char(transform);
endC := c + Length(transform);
Result := IdentityMatrix; //in case of invalid or referenced value
while ParseNextWord(c, endC, word) do
begin
if Length(word) < 5 then Exit;
if ParseNextChar(c, endC) <> '(' then Exit; //syntax check
//reset values variables
for i := 0 to High(values) do values[i] := InvalidD;
//and since every transform function requires at least one value
if not ParseNextNum(c, endC, false, values[0]) then Break;
//now get additional variables
i := 1;
while (i < 6) and IsNumPending(c, endC, true) and
ParseNextNum(c, endC, true, values[i]) do inc(i);
if ParseNextChar(c, endC) <> ')' then Exit; //syntax check
mat := IdentityMatrix;
//scal(e), matr(i)x, tran(s)late, rota(t)e, skew(X), skew(Y)
case LowerCaseTable[word[5]] of
'e' : //scalE
if not IsValid(values[1]) then
MatrixScale(mat, values[0]) else
MatrixScale(mat, values[0], values[1]);
'i' : //matrIx
if IsValid(values[5]) then
begin
mat[0,0] := values[0];
mat[0,1] := values[1];
mat[1,0] := values[2];
mat[1,1] := values[3];
mat[2,0] := values[4];
mat[2,1] := values[5];
end;
's' : //tranSlateX, tranSlateY & tranSlate
if Length(word) =10 then
begin
c2 := LowerCaseTable[word[10]];
if c2 = 'x' then
MatrixTranslate(mat, values[0], 0)
else if c2 = 'y' then
MatrixTranslate(mat, 0, values[0]);
end
else if IsValid(values[1]) then
MatrixTranslate(mat, values[0], values[1])
else
MatrixTranslate(mat, values[0], 0);
't' : //rotaTe
if IsValid(values[2]) then
MatrixRotate(mat, PointD(values[1],values[2]), DegToRad(values[0]))
else
MatrixRotate(mat, NullPointD, DegToRad(values[0]));
'x' : //skewX
begin
MatrixSkew(mat, DegToRad(values[0]), 0);
end;
'y' : //skewY
begin
MatrixSkew(mat, 0, DegToRad(values[0]));
end;
end;
MatrixMultiply2(mat, Result);
end;
end;
//------------------------------------------------------------------------------
procedure GetSvgFontInfo(const value: UTF8String; var fontInfo: TSVGFontInfo);
var
c, endC: PUTF8Char;
hash: Cardinal;
begin
c := PUTF8Char(value);
endC := c + Length(value);
while (c < endC) and SkipBlanks(c, endC) do
begin
if c = ';' then
break
else if IsNumPending(c, endC, true) then
ParseNextNum(c, endC, true, fontInfo.size)
else
begin
hash := ParseNextWordHashed(c, endC);
case hash of
hSans_045_Serif : fontInfo.family := tfSansSerif;
hSerif : fontInfo.family := tfSerif;
hMonospace : fontInfo.family := tfMonospace;
hBold : fontInfo.weight := 600;
hItalic : fontInfo.italic := sfsItalic;
hNormal :
begin
fontInfo.weight := 400;
fontInfo.italic := sfsNone;
end;
hStart : fontInfo.align := staLeft;
hMiddle : fontInfo.align := staCenter;
hEnd : fontInfo.align := staRight;
hline_045_through : fontInfo.decoration := fdStrikeThrough;
hUnderline : fontInfo.decoration := fdUnderline;
end;
end;
end;
end;
//------------------------------------------------------------------------------
function HtmlDecode(const html: UTF8String): UTF8String;
var
val, len: integer;
c,ce,endC: PUTF8Char;
ch: UTF8Char;
begin
len := Length(html);
SetLength(Result, len*3);
c := PUTF8Char(html);
endC := c + len;
ce := c;
len := 1;
while (ce < endC) and (ce^ <> '&') do
inc(ce);
while (ce < endC) do
begin
if ce > c then
begin
Move(c^, Result[len], ce - c);
inc(len, ce - c);
end;
c := ce; inc(ce);
while (ce < endC) and (ce^ <> ';') do inc(ce);
if ce = endC then break;
val := -1; //assume error
if (c +1)^ = '#' then
begin
val := 0;
//decode unicode value
if (c +2)^ = 'x' then
begin
inc(c, 3);
while c < ce do
begin
ch := c^;
case ch of
'a'..'f':
val := val * 16 + Ord(ch) - 87;
'A'..'F':
val := val * 16 + Ord(ch) - 55;
'0'..'9':
val := val * 16 + Ord(ch) - 48;
else
val := -1;
break;
end;
inc(c);
end;
end else
begin
inc(c, 2);
while c < ce do
begin
val := val * 10 + Ord(c^) - 48;
inc(c);
end;
end;
end else
begin
//decode html entity ...
case GetHashCaseSensitive(c, ce - c) of
{$I Img32.SVG.HtmlValues.inc}
end;
end;
//convert unicode value to utf8 chars
//this saves the overhead of multiple UTF8String<-->string conversions.
case val of
0 .. $7F:
begin
result[len] := UTF8Char(val);
inc(len);
end;
$80 .. $7FF:
begin
Result[len] := UTF8Char($C0 or (val shr 6));
Result[len+1] := UTF8Char($80 or (val and $3f));
inc(len, 2);
end;
$800 .. $7FFF:
begin
Result[len] := UTF8Char($E0 or (val shr 12));
Result[len+1] := UTF8Char($80 or ((val shr 6) and $3f));
Result[len+2] := UTF8Char($80 or (val and $3f));
inc(len, 3);
end;
$10000 .. $10FFFF:
begin
Result[len] := UTF8Char($F0 or (val shr 18));
Result[len+1] := UTF8Char($80 or ((val shr 12) and $3f));
Result[len+2] := UTF8Char($80 or ((val shr 6) and $3f));
Result[len+3] := UTF8Char($80 or (val and $3f));
inc(len, 4);
end;
else
begin
//ie: error
Move(c^, Result[len], ce- c +1);
inc(len, ce - c +1);
end;
end;
inc(ce);
c := ce;
while (ce < endC) and (ce^ <> '&') do inc(ce);
end;
if (c < endC) and (ce > c) then
begin
Move(c^, Result[len], (ce - c));
inc(len, ce - c);
end;
setLength(Result, len -1);
end;
//------------------------------------------------------------------------------
function HexByteToInt(h: UTF8Char): Cardinal; {$IFDEF INLINE} inline; {$ENDIF}
begin
case h of
'0'..'9': Result := Ord(h) - Ord('0');
'A'..'F': Result := 10 + Ord(h) - Ord('A');
'a'..'f': Result := 10 + Ord(h) - Ord('a');
else Result := 0;
end;
end;
//------------------------------------------------------------------------------
function IsFraction(val: double): Boolean; {$IFDEF INLINE} inline; {$ENDIF}
begin
Result := (val <> 0) and (Abs(val) < 1);
end;
//------------------------------------------------------------------------------
function UTF8StringToColor32(const value: UTF8String; var color: TColor32): Boolean;
var
i, len : integer;
j : Cardinal;
clr : TColor32;
alpha : Byte;
vals : array[0..3] of double;
mus : array[0..3] of TUnitType;
c, endC : PUTF8Char;
begin
Result := false;
len := Length(value);
if len < 3 then Exit;
c := PUTF8Char(value);
if (color = clInvalid) or (color = clCurrent) or (color = clNone32) then
alpha := 255 else
alpha := GetAlpha(color);
if Match(c, 'rgb') then
begin
endC := c + len;
inc(c, 3);
if (c^ = 'a') then inc(c);
if (ParseNextChar(c, endC) <> '(') or
not ParseNextNumEx(c, endC, false, vals[0], mus[0]) or
not ParseNextNumEx(c, endC, true, vals[1], mus[1]) or
not ParseNextNumEx(c, endC, true, vals[2], mus[2]) then Exit;
for i := 0 to 2 do
if mus[i] = utPercent then
vals[i] := vals[i] * 255 / 100;
if (c < endC) and (c^ <> ')') and ParseNextNumEx(c, endC, true, vals[3], mus[3]) then
alpha := 255 else //stops further alpha adjustment
vals[3] := 255;
if ParseNextChar(c, endC) <> ')' then Exit;
for i := 0 to 3 do if IsFraction(vals[i]) then
vals[i] := vals[i] * 255;
color := ClampByte(Integer(Round(vals[3]))) shl 24 +
ClampByte(Integer(Round(vals[0]))) shl 16 +
ClampByte(Integer(Round(vals[1]))) shl 8 +
ClampByte(Integer(Round(vals[2])));
end
else if (c^ = '#') then //#RRGGBB or #RGB
begin
if (len = 9) then
begin
clr := $0;
alpha := $0;
for i := 1 to 6 do
begin
inc(c);
clr := clr shl 4 + HexByteToInt(c^);
end;
for i := 1 to 2 do
begin
inc(c);
alpha := alpha shl 4 + HexByteToInt(c^);
end;
clr := clr or alpha shl 24;
end
else if (len = 7) then
begin
clr := $0;
for i := 1 to 6 do
begin
inc(c);
clr := clr shl 4 + HexByteToInt(c^);
end;
clr := clr or $FF000000;
end
else if (len = 5) then
begin
clr := $0;
for i := 1 to 3 do
begin
inc(c);
j := HexByteToInt(c^);
clr := clr shl 4 + j;
clr := clr shl 4 + j;
end;
inc(c);
alpha := HexByteToInt(c^);
alpha := alpha + alpha shl 4;
clr := clr or alpha shl 24;
end
else if (len = 4) then
begin
clr := $0;
for i := 1 to 3 do
begin
inc(c);
j := HexByteToInt(c^);
clr := clr shl 4 + j;
clr := clr shl 4 + j;
end;
clr := clr or $FF000000;
end
else
Exit;
color := clr;
end else //color name lookup
begin
if not ColorConstList.GetColorValue(value, color) then
Exit;
end;
//and in case the opacity has been set before the color
if (alpha < 255) then
color := (color and $FFFFFF) or alpha shl 24;
{$IF DEFINED(ANDROID)}
color := SwapRedBlue(color);
{$IFEND}
Result := true;
end;
//------------------------------------------------------------------------------
function ScaleDashArray(const dblArray: TArrayOfDouble; scale: double): TArrayOfDouble;
var
i, len: integer;
begin
len := Length(dblArray);
SetLength(Result, len);
if len = 0 then Exit;
for i := 0 to len -1 do
Result[i] := dblArray[i] * scale;
if Odd(len) then
begin
SetLength(Result, len *2);
Move(Result[0], Result[len], len * SizeOf(double));
end;
end;
//------------------------------------------------------------------------------
function PeekNextChar(var c: PUTF8Char; endC: PUTF8Char): UTF8Char;
begin
if not SkipBlanks(c, endC) then
Result := #0 else
Result := c^;
end;
//------------------------------------------------------------------------------
procedure ParseStyleElementContent(const value: UTF8String;
stylesList: TClassStylesList);
var
len, cap: integer;
names: array of UTF8String;
procedure AddName(const name: UTF8String);
begin
if len = cap then
begin
cap := cap + buffSize;
SetLength(names, cap);
end;
names[len] := name;
inc(len);
end;
var
i: integer;
aclassName: UTF8String;
aStyle: UTF8String;
c, c2, endC: PUTF8Char;
begin
//https://oreillymedia.github.io/Using_SVG/guide/style.html
stylesList.Clear;
if value = '' then Exit;
len := 0; cap := 0;
c := @value[1];
endC := c + Length(value);
c := SkipBlanksEx(c, endC);
if c >= endC then Exit;
if Match(c, '<![cdata[') then inc(c, 9);
while True do
begin
c := SkipStyleBlanks(c, endC);
if c >= endC then Break;
case c^ of
SvgDecimalSeparator, '#', 'A'..'Z', 'a'..'z': ;
else break;
end;
//get one or more class names for each pending style
c2 := c;
c := ParseNameLength(c, endC);
ToAsciiLowerUTF8String(c2, c, aclassName);
AddName(aclassName);
c := SkipStyleBlanks(c, endC);
if (c < endC) and (c^ = ',') then
begin
inc(c);
Continue;
end;
if len = 0 then break;
//now get the style
if (c >= endC) or (c^ <> '{') then Break;
inc(c);
c2 := c;
while (c < endC) and (c^ <> '}') do inc(c);
if (c = endC) then break;
ToTrimmedUTF8String(c2, c, aStyle);
if aStyle <> '' then
begin
stylesList.Preallocate(len);
//finally, for each class name add (or append) this style
for i := 0 to len - 1 do
stylesList.AddAppendStyle(names[i], aStyle);
end;
// Reset the used names array length, so we can reuse it to reduce the amount of SetLength calls
len := 0;
inc(c);
end;
end;
//------------------------------------------------------------------------------
// TXmlEl classes
//------------------------------------------------------------------------------
constructor TXmlEl.Create(owner: TSvgParser);
begin
{$IFDEF XPLAT_GENERICS}
attribs := TList<PSvgAttrib>.Create;
childs := TList<TXmlEl>.Create;
{$ELSE}
attribs := TList.Create;
childs := TList.Create;
{$ENDIF}
selfClosed := true;
Self.owner := owner;
end;
//------------------------------------------------------------------------------
destructor TXmlEl.Destroy;
begin
Clear;
attribs.Free;
childs.Free;
inherited;
end;
//------------------------------------------------------------------------------
procedure TXmlEl.Clear;
var
i: integer;
begin
for i := 0 to attribs.Count -1 do
DisposeSvgAttrib(PSvgAttrib(attribs.List[i]));
attribs.Clear;
for i := 0 to childs.Count -1 do
TXmlEl(childs[i]).free;
childs.Clear;
end;
//------------------------------------------------------------------------------
function TXmlEl.ParseHeader(var c: PUTF8Char; endC: PUTF8Char): Boolean;
var
style: UTF8String;
c2: PUTF8Char;
begin
c2 := SkipBlanksEx(c, endC);
c := ParseNameLength(c2, endC);
ToAsciiLowerUTF8String(c2, c, name);
//load the class's style (ie undotted style) if found.
style := owner.classStyles.GetStyle(name);
if style <> '' then ParseStyleAttribute(style);
Result := ParseAttributes(c, endC);
end;
//------------------------------------------------------------------------------
class function TXmlEl.ParseAttribName(c: PUTF8Char;
endC: PUTF8Char; attrib: PSvgAttrib): PUTF8Char;
begin
Result := SkipBlanksEx(c, endC);
if Result >= endC then Exit;
c := Result;
Result := ParseNameLength(Result, endC);
ToUTF8String(c, Result, attrib.Name);
attrib.hash := GetHash(attrib.Name);
end;
//------------------------------------------------------------------------------
class function TXmlEl.ParseAttribValue(c, endC: PUTF8Char;
attrib: PSvgAttrib): PUTF8Char;
// Parse: [Whitespaces] "=" [Whitespaces] ("'" | "\"") <string> ("'" | "\"")
var
quoteChar: UTF8Char;
c2: PUTF8Char;
begin
Result := endC;
// ParseNextChar:
c := SkipBlanksEx(c, endC);
if (c >= endC) or (c^ <> '=') then Exit;
inc(c); // '=' parsed
// ParseQuoteChar:
c := SkipBlanksEx(c, endC);
if c >= endC then Exit;
quoteChar := c^;
if not (quoteChar in [quote, dquote]) then Exit;
inc(c); // quote parsed
//trim leading and trailing spaces in the actual value
c := SkipBlanksEx(c, endC);
// find value end
Result := c;
while (Result < endC) and (Result^ <> quoteChar) do inc(Result);
c2 := Result;
while (c2 > c) and ((c2 -1)^ <= space) do dec(c2);
ToUTF8String(c, c2, attrib.value, sitPreserve);
inc(Result); //skip end quote
end;
//------------------------------------------------------------------------------
class function TXmlEl.ParseAttribNameAndValue(c, endC: PUTF8Char; attrib: PSvgAttrib): PUTF8Char;
begin
Result := ParseAttribName(c, endC, attrib);
if (Result < endC) then
Result := ParseAttribValue(Result, endC, attrib);
end;
//------------------------------------------------------------------------------
function TXmlEl.ParseAttributes(var c: PUTF8Char; endC: PUTF8Char): Boolean;
var
i: integer;
attrib, styleAttrib, classAttrib, idAttrib: PSvgAttrib;
classes: UTF8Strings;
ansi: UTF8String;
begin
Result := false;
styleAttrib := nil; classAttrib := nil; idAttrib := nil;
while SkipBlanks(c, endC) do
begin
case c^ of
'/', '?':
begin
inc(c);
if (c^ <> '>') then Exit; //error
selfClosed := true;
inc(c);
Result := true;
break;
end;
'>':
begin
inc(c);
Result := true;
break;
end;
'x':
if Match(c, 'xml:') then
begin
inc(c, 4); //ignore xml: prefixes
end;
end;
attrib := NewSvgAttrib();
c := ParseAttribNameAndValue(c, endC, attrib);
if c >= endC then
begin
DisposeSvgAttrib(attrib);
Exit;
end;
attribs.Add(attrib);
case attrib.hash of
hId : idAttrib := attrib;
hClass : classAttrib := attrib;
hStyle : styleAttrib := attrib;
end;
end;
if assigned(classAttrib) then
with classAttrib^ do
begin
//get the 'dotted' classname(s)
classes := Split(value);
for i := 0 to High(classes) do
begin
ansi := SvgDecimalSeparator + classes[i];
//get the style definition
ansi := owner.classStyles.GetStyle(ansi);
if ansi <> '' then ParseStyleAttribute(ansi);
end;
end;
if assigned(styleAttrib) then
ParseStyleAttribute(styleAttrib.value);
if assigned(idAttrib) then
begin
//get the 'hashed' classname
ansi := '#' + idAttrib.value;
//get the style definition
ansi := owner.classStyles.GetStyle(ansi);
if ansi <> '' then ParseStyleAttribute(ansi);
end;
end;
//------------------------------------------------------------------------------
procedure TXmlEl.ParseStyleAttribute(const style: UTF8String);
var
styleName, styleVal: UTF8String;
c, c2, endC: PUTF8Char;
attrib: PSvgAttrib;
begin
//there are 4 ways to load styles (in ascending precedence) -
//1. a class element style (called during element contruction)
//2. a non-element class style (called via a class attribute)
//3. an inline style (called via a style attribute)
//4. an id specific class style
c := PUTF8Char(style);
endC := c + Length(style);
while True do
begin
c := SkipStyleBlanks(c, endC);
if c >= endC then Break;
c2 := c;
c := ParseStyleNameLen(c, endC);
ToUTF8String(c2, c, styleName);
if styleName = '' then Break;
// ParseNextChar
c := SkipStyleBlanks(c, endC);
if (c >= endC) or (c^ <> ':') then Break; //syntax check
inc(c);
c := SkipBlanksEx(c, endC);
if c >= endC then Break;
c2 := c;
inc(c);
while (c < endC) and (c^ <> ';') do inc(c);
ToTrimmedUTF8String(c2, c, styleVal);
inc(c);
attrib := NewSvgAttrib();
attrib.name := styleName;
attrib.value := styleVal;
attrib.hash := GetHash(attrib.name);
attribs.Add(attrib);
end;
end;
//------------------------------------------------------------------------------
function TXmlEl.GetAttribCount: integer;
begin
Result := attribs.Count;
end;
//------------------------------------------------------------------------------
function TXmlEl.GetAttrib(index: integer): PSvgAttrib;
begin
Result := PSvgAttrib(attribs[index]);
end;
//------------------------------------------------------------------------------
function IsTextAreaTbreak(var c: PUTF8Char; endC: PUTF8Char): Boolean;
const
// https://www.w3.org/TR/SVGTiny12/text.html#tbreakElement
tbreak: PUTF8Char = '<tbreak/>';
begin
Result := (c + 9 < endC) and CompareMem(c, tbreak, 9);
if Result then inc(c, 8);
end;
//------------------------------------------------------------------------------
function TXmlEl.ParseContent(var c: PUTF8Char; endC: PUTF8Char): Boolean;
var
child : TSvgXmlEl;
entity : PSvgAttrib;
c2, cc : PUTF8Char;
tmpC, tmpEndC : PUTF8Char;
begin
Result := false;
// note: don't trim spaces at the start of text content.
// Text space trimming will be done later IF and when required.
while (hash = hText) or (hash = hTSpan) or
(hash = hTextArea) or SkipBlanks(c, endC) do
begin
if (c^ = '<') then
begin
inc(c);
case c^ of
'!':
begin
cc := c;
if Match(cc, '!--') then //start comment
begin
inc(cc, 3);
while (cc < endC) and ((cc^ <> '-') or
not Match(cc, '-->')) do inc(cc); //end comment
inc(cc, 3);
end else
begin
//it's very likely <![CDATA[
c2 := cc - 1;
if Match(cc, '![cdata[') then
begin
while (cc < endC) and ((cc^ <> ']') or not Match(cc, ']]>')) do
inc(cc);
ToUTF8String(c2, cc, text);
inc(cc, 3);
if (hash = hStyle) then
ParseStyleElementContent(text, owner.classStyles);
end else
begin
while (cc < endC) and (cc^ <> '<') do inc(cc);
ToUTF8String(c2, cc, text);
end;
end;
c := cc;
end;
'/', '?':
begin
//element closing tag
cc := c;
inc(cc);
if Match(cc, name) then
begin
inc(cc, Length(name));
//very rarely there's a space before '>'
cc := SkipBlanksEx(cc, endC);
Result := cc^ = '>';
inc(cc);
end;
c := cc;
Exit;
end;
else
begin
//starting a new element
child := TSvgXmlEl.Create(owner);
childs.Add(child);
if not child.ParseHeader(c, endC) then break;
if not child.selfClosed then
child.ParseContent(c, endC);
end;
end;
end
else if c^ = '>' then
begin
break; //oops! something's wrong
end
else if (c^ = '&') and IsKnownEntity(owner, c, endC, entity) then
begin
tmpC := PUTF8Char(entity.value);
tmpEndC := tmpC + Length(entity.value);
ParseContent(tmpC, tmpEndC);
end
else if (hash = hTSpan) or (hash = hText) or (hash = hTextPath) then
begin
// assume this is text content, and because text can also be mixed
// with any number of nested <tspan> elements, always put text
// content inside a pseudo 'self closed' <tspan> element
cc := c;
while (cc < endC) and (cc^ <> '<') do inc(cc);
child := TSvgXmlEl.Create(owner);
child.name := 'tspan';
child.hash := GetHash('tspan');
child.selfClosed := true; ////////////////////// :)))
childs.Add(child);
ToUTF8String(c, cc, child.text, sitPreserve);
c := cc;
end
else if (hash = hTextArea) then
begin
// also assume this is text content, but don't create
// pseudo <tspan> elements inside <textarea> elements
cc := c;
while (cc < endC) and
((cc^ <> '<') or IsTextAreaTbreak(cc, endC)) do inc(cc);
ToUTF8String(c, cc, text, sitPreserve);
c := cc;
end else
begin
cc := c;
while (cc < endC) and (cc^ <> '<') do inc(cc);
ToUTF8String(c, cc, text);
c := cc;
//if <style> element then load styles into owner.classStyles
if (hash = hStyle) then
ParseStyleElementContent(text, owner.classStyles);
end;
end;
end;
//------------------------------------------------------------------------------
// TDocTypeEl
//------------------------------------------------------------------------------
function TDocTypeEl.SkipWord(c, endC: PUTF8Char): PUTF8Char;
begin
while (c < endC) and (c^ > space) do inc(c);
inc(c);
Result := c;
end;
//------------------------------------------------------------------------------
function TDocTypeEl.ParseEntities(var c, endC: PUTF8Char): Boolean;
var
attrib: PSvgAttrib;
begin
attrib := nil;
inc(c); //skip opening '['
while (c < endC) and SkipBlanks(c, endC) do
begin
if (c^ = ']') then break
else if not Match(c, '<!entity') then
begin
while c^ > space do inc(c); //skip word.
Continue;
end;
inc(c, 8);
attrib := NewSvgAttrib();
c := ParseAttribName(c, endC, attrib);
if c >= endC then break;
SkipBlanks(c, endC);
if not IsQuoteChar(c^) then break;
if not ParseQuotedString(c, endC, attrib.value) then break;
attribs.Add(attrib);
attrib := nil;
SkipBlanks(c, endC);
if c^ <> '>' then break;
inc(c); //skip entity's trailing '>'
end;
if Assigned(attrib) then DisposeSvgAttrib(attrib);
Result := (c < endC) and (c^ = ']');
inc(c);
end;
//------------------------------------------------------------------------------
function TDocTypeEl.ParseAttributes(var c: PUTF8Char; endC: PUTF8Char): Boolean;
var
dummy : UTF8String;
begin
while SkipBlanks(c, endC) do
begin
//we're currently only interested in ENTITY declarations
case c^ of
'[': ParseEntities(c, endC);
'"', '''': ParseQuotedString(c, endC, dummy);
'>': break;
else c := SkipWord(c, endC);
end;
end;
Result := (c < endC) and (c^ = '>');
inc(c);
end;
//------------------------------------------------------------------------------
// TSvgTreeEl
//------------------------------------------------------------------------------
constructor TSvgXmlEl.Create(owner: TSvgParser);
begin
inherited Create(owner);
selfClosed := false;
end;
//------------------------------------------------------------------------------
procedure TSvgXmlEl.Clear;
var
i: integer;
begin
for i := 0 to childs.Count -1 do
TSvgXmlEl(childs[i]).free;
childs.Clear;
inherited;
end;
//------------------------------------------------------------------------------
function TSvgXmlEl.ParseHeader(var c: PUTF8Char; endC: PUTF8Char): Boolean;
begin
Result := inherited ParseHeader(c, endC);
if Result then hash := GetHash(name);
end;
//------------------------------------------------------------------------------
//function TSvgTreeEl.ParseContent(var c: PUTF8Char; endC: PUTF8Char): Boolean;
constructor TSvgParser.Create;
begin
classStyles := TClassStylesList.Create;
svgStream := TMemoryStream.Create;
xmlHeader := TXmlEl.Create(Self);
docType := TDocTypeEl.Create(Self);
svgTree := nil;
end;
//------------------------------------------------------------------------------
destructor TSvgParser.Destroy;
begin
Clear;
svgStream.Free;
xmlHeader.Free;
docType.Free;
classStyles.Free;
end;
//------------------------------------------------------------------------------
procedure TSvgParser.Clear;
begin
classStyles.Clear;
svgStream.Clear;
xmlHeader.Clear;
docType.Clear;
FreeAndNil(svgTree);
end;
//------------------------------------------------------------------------------
function TSvgParser.FindEntity(hash: Cardinal): PSvgAttrib;
var
i: integer;
begin
//there are usually so few, that there seems little point sorting etc.
for i := 0 to docType.attribs.Count -1 do
begin
Result := PSvgAttrib(docType.attribs.List[i]);
if Result.hash = hash then Exit;
end;
Result := nil;
end;
//------------------------------------------------------------------------------
function TSvgParser.LoadFromFile(const filename: string): Boolean;
var
fs: TFileStream;
begin
Result := false;
if not FileExists(filename) then Exit;
fs := TFileStream.Create(filename, fmOpenRead or fmShareDenyNone);
try
Result := LoadFromStream(fs);
finally
fs.Free;
end;
end;
//------------------------------------------------------------------------------
procedure ConvertUnicodeToUtf8(memStream: TMemoryStream);
var
i, len: LongInt;
encoding: TSvgEncoding;
s: UnicodeString;
wc: PWord;
utf8: UTF8String;
begin
memStream.Position := 0;
encoding := GetXmlEncoding(memStream.Memory, memStream.Size);
case encoding of
eUnicodeLE, eUnicodeBE: ;
else Exit;
end;
SetLength(s, memStream.Size div 2);
Move(memStream.Memory^, s[1], memStream.Size);
if encoding = eUnicodeBE then
begin
wc := @s[1];
for i := 1 to Length(s) do
begin
wc^ := Swap(wc^);
inc(wc);
end;
end;
utf8 := UTF8Encode(s);
len := Length(utf8);
memStream.SetSize(len);
Move(utf8[1], memStream.Memory^, len);
end;
//------------------------------------------------------------------------------
function TSvgParser.LoadFromStream(stream: TStream): Boolean;
begin
Clear;
Result := true;
try
svgStream.LoadFromStream(stream);
// very few SVG files are unicode encoded, almost all are Utf8
// so it's more efficient to parse them all as Utf8 encoded files
ConvertUnicodeToUtf8(svgStream);
ParseUtf8Stream;
except
Result := false;
end;
end;
//------------------------------------------------------------------------------
function TSvgParser.LoadFromString(const str: string): Boolean;
var
ss: TStringStream;
begin
{$IFDEF UNICODE}
ss := TStringStream.Create(str, TEncoding.UTF8);
{$ELSE}
ss := TStringStream.Create(UTF8Encode(str));
{$ENDIF}
try
Result := LoadFromStream(ss);
finally
ss.Free;
end;
end;
//------------------------------------------------------------------------------
procedure TSvgParser.ParseUtf8Stream;
var
c, endC: PUTF8Char;
begin
c := svgStream.Memory;
endC := c + svgStream.Size;
SkipBlanks(c, endC);
if Match(c, '<?xml') then
begin
inc(c, 2); //todo: accommodate space after '<' eg using sMatchEl function
if not xmlHeader.ParseHeader(c, endC) then Exit;
SkipBlanks(c, endC);
end;
if Match(c, '<!doctype') then
begin
inc(c, 2);
if not docType.ParseHeader(c, endC) then Exit;
end;
while SkipBlanks(c, endC) do
begin
if (c^ = '<') and Match(c, '<svg') then
begin
inc(c);
svgTree := TSvgXmlEl.Create(self);
if svgTree.ParseHeader(c, endC) and
not svgTree.selfClosed then
svgTree.ParseContent(c, endC);
break;
end;
inc(c);
end;
end;
//------------------------------------------------------------------------------
// Miscellaneous functions
//------------------------------------------------------------------------------
function DecodeUtf8ToUnicode(const utf8: UTF8String): UnicodeString;
var
i,j, len: Integer;
c, cp: Cardinal;
codePoints: TArrayOfCardinal;
begin
Result := '';
if utf8 = '' then Exit;
len := Length(utf8);
// first decode utf8String to codepoints
SetLength(codePoints, len);
i := 1;
j := 0;
while i <= len do
begin
c := Ord(utf8[i]);
if c and $80 = 0 then // c < 128
begin
codePoints[j] := c;
inc(i); inc(j);
end
else if c and $E0 = $C0 then
begin
if i = len then break;
codePoints[j] := (c and $1F) shl 6 + (Ord(utf8[i+1]) and $3F);
inc(i, 2); inc(j);
end
else if c and $F0 = $E0 then
begin
if i > len - 2 then break;
codePoints[j] := (c and $F) shl 12 +
((Ord(utf8[i+1]) and $3F) shl 6) + ((Ord(utf8[i+2]) and $3F));
inc(i, 3); inc(j);
end else
begin
if (i > len - 3) or (c shr 3 <> $1E) then break;
codePoints[j] := (c and $7) shl 18 + ((Ord(utf8[i+1]) and $3F) shl 12) +
((Ord(utf8[i+2]) and $3F) shl 6) + (Ord(utf8[i+3]) and $3F);
inc(i, 4); inc(j);
end;
end;
len := j; // there are now 'j' valid codepoints
j := 0;
// make room in the result for surrogate paired chars, and
// convert codepoints into the result (a Utf16 string)
SetLength(Result, len *2);
for i := 0 to len -1 do
begin
inc(j);
cp := codePoints[i];
if (cp < $D7FF) or (cp = $E000) or (cp = $FFFF) then
begin
Result[j] := WideChar(cp);
end else if (cp > $FFFF) and (cp < $110000) then
begin
Dec(cp, $10000);
Result[j] := WideChar($D800 + (cp shr 10));
inc(j);
Result[j] := WideChar($DC00 + (cp and $3FF));
end;
end;
SetLength(Result, j);
end;
//------------------------------------------------------------------------------
// TValue
//------------------------------------------------------------------------------
function ConvertValue(const value: TValue; scale: double): double;
const
mm = 96 / 25.4;
cm = 96 / 2.54;
rad = 180 / PI;
pt = 4 / 3;
begin
//https://oreillymedia.github.io/Using_SVG/guide/units.html
//todo: still lots of units to support (eg times for animation)
with value do
{if not IsValid or (rawVal = 0) then // already checked by TValue.GetValue, the only function calling this code
Result := 0
else}
case value.unitType of
utNumber:
Result := rawVal;
utPercent:
Result := rawVal * 0.01 * scale;
utRadian:
Result := rawVal * rad;
utInch:
Result := rawVal * 96;
utCm:
Result := rawVal * cm;
utMm:
Result := rawVal * mm;
utEm:
if scale <= 0 then
Result := rawVal * 16 else
Result := rawVal * scale;
utEx:
if scale <= 0 then
Result := rawVal * 8 else
Result := rawVal * scale * 0.5;
utPica:
Result := rawVal * 16;
utPt:
Result := rawVal * pt;
else
Result := rawVal;
end;
end;
//------------------------------------------------------------------------------
procedure TValue.Init;
begin
rawVal := InvalidD;
unitType := utNumber;
end;
//------------------------------------------------------------------------------
procedure TValue.SetValue(val: double; unitTyp: TUnitType);
begin
rawVal := val;
unitType := unitTyp;
end;
//------------------------------------------------------------------------------
function TValue.GetValue(relSize: double; assumeRelValBelow: Double): double;
begin
if not IsValid or (rawVal = 0) then
Result := 0
else if IsRelativeValue(assumeRelValBelow) then
Result := rawVal * relSize
else
Result := ConvertValue(self, relSize);
end;
//------------------------------------------------------------------------------
function TValue.GetValueXY(const relSize: TRectD; assumeRelValBelow: Double): double;
begin
//https://www.w3.org/TR/SVG11/coords.html#Units
Result := GetValue(Hypot(relSize.Width, relSize.Height)/sqrt2, assumeRelValBelow);
end;
//------------------------------------------------------------------------------
function TValue.IsRelativeValue(assumeRelValBelow: double): Boolean;
begin
Result := (unitType = utNumber) and (Abs(rawVal) <= assumeRelValBelow);
end;
//------------------------------------------------------------------------------
function TValue.IsValid: Boolean;
begin
Result := (unitType <> utUnknown) and Img32.Vector.IsValid(rawVal);
end;
//------------------------------------------------------------------------------
function TValue.HasFontUnits: Boolean;
begin
case unitType of
utEm, utEx: Result := true;
else Result := False;
end;
end;
//------------------------------------------------------------------------------
function TValue.HasAngleUnits: Boolean;
begin
case unitType of
utDegree, utRadian: Result := true;
else Result := False;
end;
end;
//------------------------------------------------------------------------------
// TValuePt
//------------------------------------------------------------------------------
procedure TValuePt.Init;
begin
X.Init;
Y.Init;
end;
//------------------------------------------------------------------------------
function TValuePt.GetPoint(const relSize: double; assumeRelValBelow: Double): TPointD;
begin
Result.X := X.GetValue(relSize, assumeRelValBelow);
Result.Y := Y.GetValue(relSize, assumeRelValBelow);
end;
//------------------------------------------------------------------------------
function TValuePt.GetPoint(const relSize: TRectD; assumeRelValBelow: Double): TPointD;
begin
Result.X := X.GetValue(relSize.Width, assumeRelValBelow);
Result.Y := Y.GetValue(relSize.Height, assumeRelValBelow);
end;
//------------------------------------------------------------------------------
function TValuePt.IsValid: Boolean;
begin
Result := X.IsValid and Y.IsValid;
end;
//------------------------------------------------------------------------------
// TValueRec
//------------------------------------------------------------------------------
procedure TValueRecWH.Init;
begin
left.Init;
top.Init;
width.Init;
height.Init;
end;
//------------------------------------------------------------------------------
function TValueRecWH.GetRectD(const relSize: TRectD; assumeRelValBelow: Double): TRectD;
begin
with GetRectWH(relSize, assumeRelValBelow) do
begin
Result.Left :=Left;
Result.Top := Top;
Result.Right := Left + Width;
Result.Bottom := Top + Height;
end;
end;
//------------------------------------------------------------------------------
function TValueRecWH.GetRectD(relSize: double; assumeRelValBelow: Double): TRectD;
begin
if not left.IsValid then
Result.Left := 0 else
Result.Left := left.GetValue(relSize, assumeRelValBelow);
if not top.IsValid then
Result.Top := 0 else
Result.Top := top.GetValue(relSize, assumeRelValBelow);
Result.Right := Result.Left + width.GetValue(relSize, assumeRelValBelow);
Result.Bottom := Result.Top + height.GetValue(relSize, assumeRelValBelow);
end;
//------------------------------------------------------------------------------
function TValueRecWH.GetRectD(relSizeX, relSizeY: double; assumeRelValBelow: Double): TRectD;
begin
if not left.IsValid then
Result.Left := 0 else
Result.Left := left.GetValue(relSizeX, assumeRelValBelow);
if not top.IsValid then
Result.Top := 0 else
Result.Top := top.GetValue(relSizeY, assumeRelValBelow);
Result.Right := Result.Left + width.GetValue(relSizeX, assumeRelValBelow);
Result.Bottom := Result.Top + height.GetValue(relSizeY, assumeRelValBelow);
end;
//------------------------------------------------------------------------------
function TValueRecWH.GetRectWH(const relSize: TRectD; assumeRelValBelow: Double): TRectWH;
begin
if not left.IsValid then
Result.Left := 0 else
Result.Left := left.GetValue(relSize.Width, assumeRelValBelow);
if not top.IsValid then
Result.Top := 0 else
Result.Top := top.GetValue(relSize.Height, assumeRelValBelow);
Result.Width := width.GetValue(relSize.Width, assumeRelValBelow);
Result.Height := height.GetValue(relSize.Height, assumeRelValBelow);
end;
//------------------------------------------------------------------------------
function TValueRecWH.IsValid: Boolean;
begin
Result := width.IsValid and height.IsValid;
end;
//------------------------------------------------------------------------------
function TValueRecWH.IsEmpty: Boolean;
begin
Result := (width.rawVal <= 0) or (height.rawVal <= 0);
end;
//------------------------------------------------------------------------------
// TClassStylesList
//------------------------------------------------------------------------------
procedure TClassStylesList.Grow(NewCapacity: Integer);
var
Len, I: Integer;
Index: Integer;
begin
Len := Length(FItems);
if NewCapacity < 0 then
begin
if Len < 5 then
Len := 5
else
Len := Len * 2;
end
else if NewCapacity <= Len then
Exit
else
Len := NewCapacity;
SetLength(FItems, Len);
FMod := Cardinal(Len);
if not Odd(FMod) then
Inc(FMod);
SetLengthUninit(FBuckets, FMod);
FillChar(FBuckets[0], FMod * SizeOf(FBuckets[0]), $FF);
// Rehash
for I := 0 to FCount - 1 do
begin
Index := (FItems[I].Hash and $7FFFFFFF) mod FMod;
FItems[I].Next := FBuckets[Index];
FBuckets[Index] := I;
end;
end;
//------------------------------------------------------------------------------
procedure TClassStylesList.Preallocate(AdditionalItemCount: Integer);
begin
if AdditionalItemCount > 2 then
Grow(Length(FItems) + AdditionalItemCount);
end;
//------------------------------------------------------------------------------
function TClassStylesList.FindItemIndex(const Name: UTF8String): Integer;
begin
Result := -1;
FNameHash := GetHash(Name);
if FMod <> 0 then
begin
Result := FBuckets[(FNameHash and $7FFFFFFF) mod FMod];
while (Result <> -1) and
((FItems[Result].Hash <> FNameHash) or
not IsSameUTF8String(FItems[Result].Name, Name)) do
Result := FItems[Result].Next;
end;
end;
//------------------------------------------------------------------------------
procedure TClassStylesList.AddAppendStyle(const Name, Style: UTF8String);
var
Index: Integer;
Item: PClassStyleListItem;
Bucket: PInteger;
begin
Index := FindItemIndex(Name);
if Index <> -1 then
begin
Item := @FItems[Index];
if (Item.Style <> '') and (Item.Style[Length(Item.Style)] <> ';') then
Item.Style := Item.Style + ';' + Style
else
Item.Style := Item.Style + Style;
end
else
begin
if FCount = Length(FItems) then
Grow;
Index := FCount;
Inc(FCount);
Bucket := @FBuckets[(FNameHash and $7FFFFFFF) mod FMod];
Item := @FItems[Index];
Item.Next := Bucket^;
Item.Hash := FNameHash;
Item.Name := Name;
Item.Style := style;
Bucket^ := Index;
end;
end;
//------------------------------------------------------------------------------
function TClassStylesList.GetStyle(const Name: UTF8String): UTF8String;
var
Index: Integer;
begin
if FCount = 0 then
Result := ''
else
begin
Index := FindItemIndex(Name);
if Index <> -1 then
Result := FItems[Index].Style
else
Result := '';
end;
end;
//------------------------------------------------------------------------------
procedure TClassStylesList.Clear;
begin
FCount := 0;
FMod := 0;
FItems := nil;
FBuckets := nil;
end;
//------------------------------------------------------------------------------
// TColorConstList
//------------------------------------------------------------------------------
constructor TColorConstList.Create(Colors: PColorConst; Count: Integer);
var
I: Integer;
Bucket: PPColorConstMapItem;
Item: PColorConstMapItem;
begin
inherited Create;
FCount := Count;
SetLength(FItems, FCount);
FMod := FCount * 2 + 1; // gives us 3 color constants as max. bucket depth
SetLength(FBuckets, FMod);
// Initialize FItems[] and fill the buckets
for I := 0 to Count - 1 do
begin
Item := @FItems[I];
Item.Data := Colors; // link the constant to the ColorConstMapItem
Inc(Colors);
Item.Hash := GetHash(Item.Data.ColorName); // case-insensitive
Bucket := @FBuckets[(Cardinal(Item.Hash) and $7FFFFFFF) mod FMod];
Item.Next := Bucket^;
Bucket^ := Item;
end;
end;
//------------------------------------------------------------------------------
function TColorConstList.GetColorValue(const ColorName: UTF8String; var Color: TColor32): Boolean;
var
Hash: Cardinal;
Item: PColorConstMapItem;
begin
Hash := GetHash(ColorName);
Item := FBuckets[(Cardinal(Hash) and $7FFFFFFF) mod FMod];
while (Item <> nil) and
not IsSameAsciiUTF8String(Item.Data.ColorName, ColorName) do
Item := Item.Next;
if Item <> nil then
begin
Color := Item.Data.ColorValue;
Result := True;
end
else
Result := False;
end;
//------------------------------------------------------------------------------
// initialization procedures
//------------------------------------------------------------------------------
procedure MakeLowerCaseTable;
var
i: UTF8Char;
begin
for i:= #0 to #$40 do LowerCaseTable[i]:= i;
for i:= #$41 to #$5A do LowerCaseTable[i]:= UTF8Char(Ord(i) + $20);
for i:= #$5B to #$FF do LowerCaseTable[i]:= i;
end;
//------------------------------------------------------------------------------
procedure MakeColorConstList;
{$I Img32.SVG.HtmlColorConsts.inc}
begin
ColorConstList := TColorConstList.Create(@ColorConsts, Length(ColorConsts));
end;
//------------------------------------------------------------------------------
procedure CleanupColorConstList;
begin
FreeAndNil(ColorConstList);
end;
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
initialization
MakeLowerCaseTable;
MakeColorConstList;
finalization
CleanupColorConstList;
end.
Reference in a new issue View git blame Copy permalink