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 ; {$ELSE} attribs : TList; {$ENDIF} function GetAttrib(index: integer): PSvgAttrib; function GetAttribCount: integer; public {$IFDEF XPLAT_GENERICS} childs : TList; {$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, '= 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.Create; childs := TList.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] ("'" | "\"") ("'" | "\"") 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 = ''; 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 ']') 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 elements, always put text // content inside a pseudo 'self closed' 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 elements inside