xtool/contrib/fundamentals/HTMLParser/flcHTMLStyleSheet.pas

1509 lines
44 KiB
ObjectPascal

{******************************************************************************}
{ }
{ Library: Fundamentals 5.00 - HTML Parser }
{ File name: flcHTMLStyleSheet.pas }
{ File version: 5.05 }
{ Description: HTML Style Sheet }
{ }
{ Copyright: Copyright (c) 2000-2020, David J Butler }
{ All rights reserved. }
{ Redistribution and use in source and binary forms, with }
{ or without modification, are permitted provided that }
{ the following conditions are met: }
{ Redistributions of source code must retain the above }
{ copyright notice, this list of conditions and the }
{ following disclaimer. }
{ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND }
{ CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED }
{ WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED }
{ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A }
{ PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL }
{ THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, }
{ INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR }
{ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, }
{ PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF }
{ USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) }
{ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER }
{ IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING }
{ NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE }
{ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE }
{ POSSIBILITY OF SUCH DAMAGE. }
{ }
{ Github: https://github.com/fundamentalslib }
{ E-mail: fundamentals.library at gmail.com }
{ }
{ Revision history: }
{ }
{ 2002/11/04 1.00 Initial version. }
{ 2002/11/22 1.01 Refactored. }
{ 2002/12/03 1.02 Redesigned style resolution. }
{ 2002/12/08 1.03 Created seperate unit for ThtmlcssProperty classes. }
{ 2015/04/11 1.04 UnicodeString changes. }
{ 2019/02/22 5.05 Revise for Fundamentals 5. }
{ }
{******************************************************************************}
{$INCLUDE flcHTML.inc}
unit flcHTMLStyleSheet;
interface
uses
{ System }
{$IFDEF DELPHI6_UP}
Types,
{$ELSE}
Windows,
{$ENDIF}
SysUtils,
System.UITypes,
{ Fundamentals }
flcStdTypes,
flcDataStructs,
{ HTML }
flcHTMLElements,
flcHTMLProperties,
flcHTMLStyleTypes,
flcHTMLStyleProperties;
{ }
{ EhtmlCSS }
{ }
type
EhtmlCSS = class(Exception);
{ }
{ ThtmlcssElementInfo }
{ HTML element information required by ThtmlcssSelector. }
{ }
type
PhtmlcssElementInfo = ^ThtmlcssElementInfo;
ThtmlcssElementInfo = record
ElementID : Integer;
ClassIDs : IntegerArray;
TagID : ThtmlTagID;
PseudoIDs : ThtmlcssPseudoPropertyIDSet;
ParentInfo : PhtmlcssElementInfo;
end;
{ }
{ ThtmlcssStyleProperties }
{ }
procedure InitDefaultStyleProperties(var StyleInfo: ThtmlcssStyleProperties);
procedure InitElementStyleProperties(var StyleInfo: ThtmlcssStyleProperties;
const ParentStyle: ThtmlcssStyleProperties;
const ElementInfo: ThtmlcssElementInfo);
function StyleResolveSystemFontName(const StyleInfo: ThtmlcssStyleProperties): String;
function StyleResolveSystemFontSize(const StyleInfo: ThtmlcssStyleProperties): Integer;
procedure StyleResolveSystemFont(const StyleInfo: ThtmlcssStyleProperties;
var Name: String; var Styles: TFontStyles; var Size: Integer);
function StyleResolveSystemColor(const Color: ThtmlColor): TColor;
{ }
{ ThtmlcssSelector }
{ }
type
ThtmlcssSelector = class
protected
FNext : ThtmlcssSelector;
FTagID : ThtmlTagID;
FClassID : Integer;
FElementID : Integer;
FPseudoPropIDs : ThtmlcssPseudoPropertyIDSet;
FAncestorSelector : ThtmlcssSelector;
FSpecificity : Integer;
public
constructor Create(const TagID: ThtmlTagID; const ClassID: Integer;
const ElementID: Integer; const PseudoPropIDs: ThtmlcssPseudoPropertyIDSet;
const AncestorSelector: ThtmlcssSelector);
destructor Destroy; override;
property Specificity: Integer read FSpecificity;
function Match(const ElementInfo: ThtmlcssElementInfo): Boolean;
end;
{ }
{ ThtmlcssSelectors }
{ }
type
ThtmlcssSelectors = class
protected
FFirst : ThtmlcssSelector;
FLast : ThtmlcssSelector;
procedure AddSelector(const Selector: ThtmlcssSelector);
public
destructor Destroy; override;
function MatchingSelector(const ElementInfo: ThtmlcssElementInfo): ThtmlcssSelector;
end;
{ }
{ ThtmlcssDeclarations }
{ }
type
ThtmlcssDeclarations = class
protected
FFirst : ThtmlcssProperty;
FLast : ThtmlcssProperty;
procedure AddDeclaration(const Declaration: ThtmlcssProperty);
public
destructor Destroy; override;
procedure ApplyStyleInfo(var StyleInfo: ThtmlcssStyleProperties;
const ParentStyle: ThtmlcssStyleProperties);
end;
{ }
{ ThtmlcssMatchingDeclarations }
{ }
type
ThtmlcssMatchingDeclarationsItem = record
Specificity : Integer;
Order : Integer;
Declarations : ThtmlcssDeclarations;
end;
PhtmlcssMatchingDeclarationsItem = ^ThtmlcssMatchingDeclarationsItem;
ThtmlcssMatchingDeclarations = class
protected
FMatches : Array of ThtmlcssMatchingDeclarationsItem;
FCount : Integer;
public
property Count: Integer read FCount;
procedure Clear;
procedure AddMatch(const Specificity: Integer;
const Declarations: ThtmlcssDeclarations);
procedure Sort;
procedure ApplyStyleInfo(var StyleInfo: ThtmlcssStyleProperties;
const ParentStyle: ThtmlcssStyleProperties);
end;
{ }
{ ThtmlcssRule }
{ }
type
ThtmlcssRule = class
protected
FNext : ThtmlcssRule;
FSelectors : ThtmlcssSelectors;
FDeclarations : ThtmlcssDeclarations;
public
constructor Create(const Selectors: ThtmlcssSelectors;
const Declarations: ThtmlcssDeclarations);
destructor Destroy; override;
procedure AddMatch(const ElementInfo: ThtmlcssElementInfo;
const Matches: ThtmlcssMatchingDeclarations);
end;
{ }
{ ThtmlcssRuleSet }
{ }
type
ThtmlCSS = class;
ThtmlcssStyleSheetState = (ssNotImported, ssReady, ssBusyImporting,
ssImportFailed);
ThtmlcssRuleSetState = (rsLocal, rsNotImported, rsBusyImporting, rsImported,
rsImportFailed);
ThtmlcssRuleSet = class
protected
FCSS : ThtmlCSS;
FSource : String;
FState : ThtmlcssRuleSetState;
FFirst : ThtmlcssRule;
FLast : ThtmlcssRule;
FImports : array of ThtmlcssRuleSet;
public
constructor Create(const CSS: ThtmlCSS; const State: ThtmlcssRuleSetState;
const Source: String);
destructor Destroy; override;
property CSS: ThtmlCSS read FCSS;
property State: ThtmlcssRuleSetState read FState write FState;
procedure AddRule(const Rule: ThtmlcssRule);
procedure AddImport(const Source: String);
procedure GetRequiredImports(var Sources: StringArray);
procedure SetImportedStyleState(const Source: String;
const State: ThtmlcssRuleSetState;
const StyleText: String);
function GetStyleSheetState: ThtmlcssStyleSheetState;
procedure GetImportProgress(var StateVal, TotVal: Integer);
procedure GetMatches(const ElementInfo: ThtmlcssElementInfo;
const Matches: ThtmlcssMatchingDeclarations);
end;
{ }
{ ThtmlCSS }
{ }
ThtmlcssParser = class;
ThtmlCSS = class
protected
FParser : ThtmlcssParser;
FRuleSet : ThtmlcssRuleSet;
FClassIDs : THashedUnicodeStringArray;
FElementIDs : THashedUnicodeStringArray;
FMatches : ThtmlcssMatchingDeclarations;
function AddClassID(const ClassID: String): Integer;
function AddElementID(const ElementID: String): Integer;
public
constructor Create;
destructor Destroy; override;
property Parser: ThtmlcssParser read FParser;
property RuleSet: ThtmlcssRuleSet read FRuleSet;
function GetClassID(const ClassIDBuf: PWideChar; const ClassIDLen: Integer): Integer; overload;
function GetClassID(const ClassID: String): Integer; overload;
function RequireClassID(const ClassIDBuf: PWideChar; const ClassIDLen: Integer): Integer; overload;
function RequireClassID(const ClassID: String): Integer; overload;
function GetElementID(const ElementID: String): Integer;
function RequireElementID(const ElementID: String): Integer;
// Initialize document style
procedure InitStyle(const ReaderStyleText, DocumentStyleText: String;
DocumentStyleRef: StringArray);
function GetRequiredImports: StringArray;
procedure SetImportedStyleState(const Source: String;
const State: ThtmlcssRuleSetState; const StyleText: String);
function GetStyleSheetState: ThtmlcssStyleSheetState;
function GetImportProgress: Integer;
// Initialize element style
function ParseDeclarations(const Text: String): ThtmlcssDeclarations;
procedure ApplyStyleInfo(var StyleInfo: ThtmlcssStyleProperties;
const ParentStyle: ThtmlcssStyleProperties;
const ElementInfo: ThtmlcssElementInfo);
end;
{ }
{ ThtmlcssParser }
{ }
ThtmlcssParser = class
protected
FData : Pointer;
FDataSize : Integer;
FDataPos : Integer;
FText : String;
procedure Init;
procedure SetText(const Text: String);
function GetBuf(var Buf: PWideChar; var Size: Integer): Boolean;
function SkipSpace(var P: PWideChar): Integer;
function ParseDeclaration: ThtmlcssProperty;
function ParseSelector(const RuleSet: ThtmlcssRuleSet): ThtmlcssSelector;
function ParseSelectors(const RuleSet: ThtmlcssRuleSet): ThtmlcssSelectors;
function ParseRule(const RuleSet: ThtmlcssRuleSet): ThtmlcssRule;
public
procedure InitBuf(const Buf: Pointer; const Size: Integer);
procedure InitText(const Text: String);
property Data: Pointer read FData;
property DataSize: Integer read FDataSize;
property Text: String read FText write SetText;
function ParseDeclarations: ThtmlcssDeclarations;
procedure ParseRules(const RuleSet: ThtmlcssRuleSet);
end;
implementation
uses
{ System }
{$IFDEF DELPHI6_UP}
Windows,
{$ENDIF}
{ Fundamentals }
flcUtils,
flcDynArrays,
flcStrings,
flcZeroTermStrings;
{ }
{ ThtmlcssStyleProperties }
{ }
procedure InitDefaultStyleProperties(var StyleInfo: ThtmlcssStyleProperties);
begin
FillChar(StyleInfo, Sizeof(StyleInfo), #0);
with StyleInfo do
begin
BackColor.ColorType := colorNamed;
BackColor.NamedColor := 'white';
SetLength(FontFamily, 1);
FontFamily[0].FamilyType := ffamGenericFamily;
FontFamily[0].GenericFamily := gffamSerif;
FontStyle := fstyleNormal;
FontVariant := fvariantNormal;
FontWeight := fweightNormal;
FontSize.SizeType := fsizeHTMLAbsolute;
FontSize.Value := 3.0;
FontColor.ColorType := colorNamed;
FontColor.NamedColor := 'black';
TextDecoration := tdecoNone;
VerticalAlign.AlignType := valignBaseline;
TextAlign := talignLeft;
LineHeight.LengthType := lenDefault;
WhiteSpace := wsNormal;
end;
end;
procedure InitElementStyleProperties(var StyleInfo: ThtmlcssStyleProperties;
const ParentStyle: ThtmlcssStyleProperties; const ElementInfo: ThtmlcssElementInfo);
var FontWeight: ThtmlFontWeight;
begin
case ElementInfo.TagID of
HTML_TAG_BODY :
begin
SetLength(StyleInfo.FontFamily, 1);
StyleInfo.FontFamily[0].FamilyType := ffamGenericFamily;
StyleInfo.FontFamily[0].GenericFamily := gffamSerif;
StyleInfo.FontColor.ColorType := colorNamed;
StyleInfo.FontColor.NamedColor := 'black';
StyleInfo.BackColor.ColorType := colorNamed;
StyleInfo.BackColor.NamedColor := 'white';
StyleInfo.FontSize.SizeType := fsizeHTMLAbsolute;
StyleInfo.FontSize.Value := 3.0;
end;
HTML_TAG_A :
begin
if HTML_CSS_PP_Link in ElementInfo.PseudoIDs then
begin
StyleInfo.FontColor.ColorType := colorNamed;
StyleInfo.FontColor.NamedColor := 'blue';
StyleInfo.TextDecoration := tdecoUnderline;
end else
if HTML_CSS_PP_Visited in ElementInfo.PseudoIDs then
begin
StyleInfo.FontColor.ColorType := colorNamed;
StyleInfo.FontColor.NamedColor := 'red';
StyleInfo.TextDecoration := tdecoUnderline;
end;
end;
HTML_TAG_PRE,
HTML_TAG_TT,
HTML_TAG_CODE,
HTML_TAG_KBD,
HTML_TAG_SAMP :
begin
SetLength(StyleInfo.FontFamily, 1);
StyleInfo.FontFamily[0].FamilyType := ffamGenericFamily;
StyleInfo.FontFamily[0].GenericFamily := gffamMonospace;
if ElementInfo.TagID = HTML_TAG_PRE then
StyleInfo.WhiteSpace := wsPre;
end;
HTML_TAG_H1 :
begin
StyleInfo.FontWeight := fweightBold;
StyleInfo.FontSize.SizeType := fsizeHTMLAbsolute;
StyleInfo.FontSize.Value := 7.0;
{ HTML_CSS_PROP_Text_Align: Value := 'center'; }
end;
HTML_TAG_H2 :
begin
StyleInfo.FontWeight := fweightBold;
StyleInfo.FontSize.SizeType := fsizeHTMLAbsolute;
StyleInfo.FontSize.Value := 6.0;
end;
HTML_TAG_H3 :
begin
StyleInfo.FontStyle := fstyleItalic;
StyleInfo.FontSize.SizeType := fsizeHTMLAbsolute;
StyleInfo.FontSize.Value := 5.0;
end;
HTML_TAG_H4 :
begin
StyleInfo.FontWeight := fweightBold;
end;
HTML_TAG_H5 :
begin
StyleInfo.FontStyle := fstyleItalic;
end;
HTML_TAG_H6 :
begin
StyleInfo.FontWeight := fweightBold;
end;
HTML_TAG_B,
HTML_TAG_STRONG :
begin
FontWeight := fweightBolder;
htmlResolveRelFontWeight(FontWeight, ParentStyle.FontWeight);
StyleInfo.FontWeight := FontWeight;
end;
HTML_TAG_I,
HTML_TAG_CITE,
HTML_TAG_EM,
HTML_TAG_VAR,
HTML_TAG_ADDRESS,
HTML_TAG_BLOCKQUOTE :
begin
StyleInfo.FontStyle := fstyleItalic;
end;
end;
// non-inherited properties reset to default for every element
htmlcssStyleResetNonInherited(StyleInfo);
end;
function StyleResolveSystemFontName(const StyleInfo: ThtmlcssStyleProperties): String;
var I: Integer;
begin
Result := '';
for I := 0 to Length(StyleInfo.FontFamily) - 1 do
with StyleInfo.FontFamily[I] do
begin
case FamilyType of
ffamFamilyName :
Result := FamilyName;
ffamGenericFamily :
case GenericFamily of
gffamSerif : Result := 'Times New Roman';
gffamSansSerif : Result := 'MS Arial';
gffamCursive : Result := 'Script';
gffamFantasy : Result := 'Comic Sans MS';
gffamMonospace : Result := 'Courier New';
end;
end;
if Result <> '' then
exit;
end;
end;
function StyleResolveSystemFontSize(const StyleInfo: ThtmlcssStyleProperties): Integer;
begin
Result := htmlResolveFontSizePoints(StyleInfo.FontSize);
if Result = 0 then
Result := -htmlResolveFontSizePixels(StyleInfo.FontSize);
end;
procedure StyleResolveSystemFont(const StyleInfo: ThtmlcssStyleProperties;
var Name: String; var Styles: TFontStyles; var Size: Integer);
begin
Name := StyleResolveSystemFontName(StyleInfo);
// Styles
Styles := [];
if htmlIsFontWeightBold(StyleInfo.FontWeight) then
Include(Styles, TFontStyle.fsBold);
case StyleInfo.TextDecoration of
tdecoUnderline : Include(Styles, TFontStyle.fsUnderline);
tdecoLineThrough : Include(Styles, TFontStyle.fsStrikeOut);
end;
Size := StyleResolveSystemFontSize(StyleInfo);
end;
function StyleResolveSystemColor(const Color: ThtmlColor): TColor;
begin
Result := htmlColorValue(Color).Color;
end;
{ }
{ ThtmlcssSelector }
{ }
constructor ThtmlcssSelector.Create(const TagID: ThtmlTagID;
const ClassID: Integer; const ElementID: Integer;
const PseudoPropIDs: ThtmlcssPseudoPropertyIDSet;
const AncestorSelector: ThtmlcssSelector);
var I: ThtmlcssPseudoPropertyID;
begin
inherited Create;
FTagID := TagID;
FClassID := ClassID;
FElementID := ElementID;
FPseudoPropIDs := PseudoPropIDs;
FAncestorSelector := AncestorSelector;
// calculate specificity
FSpecificity := 0;
if FElementID >= 0 then
Inc(FSpecificity, $10000);
if FClassID >= 0 then
Inc(FSpecificity, $100);
if FTagID <> HTML_TAG_None then
Inc(FSpecificity, $1);
for I := HTML_CSS_PP_FirstID to HTML_CSS_PP_LastID do
if I in FPseudoPropIDs then
if I in HTML_CSS_PP_PseudoClasses then
Inc(FSpecificity, $100) else // pseudo-class has same weight as class
Inc(FSpecificity, $1); // pseudo-element has same weight as element
if Assigned(FAncestorSelector) then
Inc(FSpecificity, FAncestorSelector.Specificity);
Assert(FSpecificity > 0, 'FSpecificity > 0');
end;
destructor ThtmlcssSelector.Destroy;
begin
FreeAndNil(FAncestorSelector);
inherited Destroy;
end;
function ThtmlcssSelector.Match(const ElementInfo: ThtmlcssElementInfo): Boolean;
var I: Integer;
P: PhtmlcssElementInfo;
ClassIDMatch: Boolean;
begin
Result := False;
// check tag match
if (FTagID <> HTML_TAG_None) and (ElementInfo.TagID <> FTagID) then
exit;
// check class ID match
if FClassID >= 0 then
begin
ClassIDMatch := False;
for I := 0 to Length(ElementInfo.ClassIDs) - 1 do
if ElementInfo.ClassIDs[I] = FClassID then
begin
ClassIDMatch := True;
break;
end;
if not ClassIDMatch then
exit;
end;
// check ID match
if (FElementID >= 0) and (ElementInfo.ElementID <> FElementID) then
exit;
// check pseudo ID match
if (FPseudoPropIDs <> []) and (ElementInfo.PseudoIDs * FPseudoPropIDs <> FPseudoPropIDs) then
exit;
// check context selector pattern match (nfa)
if Assigned(FAncestorSelector) then
begin
P := ElementInfo.ParentInfo;
while Assigned(P) do
begin
if FAncestorSelector.Match(P^) then
// match
break;
P := P.ParentInfo;
end;
if not Assigned(P) then
// no match
exit;
end;
// selector matches
Result := True;
end;
{ }
{ ThtmlcssSelectors }
{ }
destructor ThtmlcssSelectors.Destroy;
var I, N: ThtmlcssSelector;
begin
I := FFirst;
while Assigned(I) do
begin
N := I.FNext;
I.Free;
I := N;
end;
inherited;
end;
procedure ThtmlcssSelectors.AddSelector(const Selector: ThtmlcssSelector);
begin
if not Assigned(FFirst) then
FFirst := Selector;
if Assigned(FLast) then
FLast.FNext := Selector;
FLast := Selector;
Selector.FNext := nil;
end;
function ThtmlcssSelectors.MatchingSelector(const ElementInfo: ThtmlcssElementInfo): ThtmlcssSelector;
var Pri, MaxPri: Integer;
Selector: ThtmlcssSelector;
begin
// locate matching selector with highest priority
Result := nil;
MaxPri := 0;
Selector := FFirst;
while Assigned(Selector) do
begin
if Selector.Match(ElementInfo) then
begin
Pri := Selector.Specificity;
if Pri > MaxPri then
begin
MaxPri := Pri;
Result := Selector;
end;
end;
Selector := Selector.FNext;
end;
end;
{ }
{ ThtmlcssDeclarations }
{ }
destructor ThtmlcssDeclarations.Destroy;
var I, N: ThtmlcssProperty;
begin
I := FFirst;
while Assigned(I) do
begin
N := I.Next;
I.Free;
I := N;
end;
inherited Destroy;
end;
procedure ThtmlcssDeclarations.AddDeclaration(const Declaration: ThtmlcssProperty);
begin
if not Assigned(FFirst) then
FFirst := Declaration;
if Assigned(FLast) then
FLast.Next := Declaration;
FLast := Declaration;
Declaration.Next := nil;
end;
procedure ThtmlcssDeclarations.ApplyStyleInfo(var StyleInfo: ThtmlcssStyleProperties;
const ParentStyle: ThtmlcssStyleProperties);
var I: ThtmlcssProperty;
begin
// apply declaration's style info
I := FFirst;
while Assigned(I) do
begin
I.ApplyStyleInfo(StyleInfo, ParentStyle);
I := I.Next;
end;
end;
{ }
{ ThtmlcssMatchingDeclarations }
{ }
procedure ThtmlcssMatchingDeclarations.Clear;
begin
FCount := 0;
end;
procedure ThtmlcssMatchingDeclarations.AddMatch(const Specificity: Integer;
const Declarations: ThtmlcssDeclarations);
var L: Integer;
begin
L := FCount;
Inc(FCount);
if L >= Length(FMatches) then
SetLength(FMatches, L + 1);
FMatches[L].Specificity := Specificity;
FMatches[L].Declarations := Declarations;
FMatches[L].Order := L;
end;
procedure ThtmlcssMatchingDeclarations.Sort;
procedure QuickSort(L, R: Integer);
var I, J, M : Integer;
IV, JV, MV : PhtmlcssMatchingDeclarationsItem;
Tmp : ThtmlcssMatchingDeclarationsItem;
begin
repeat
I := L;
J := R;
M := (L + R) shr 1;
repeat
MV := @FMatches[M];
repeat
IV := @FMatches[I];
if (IV^.Specificity < MV^.Specificity) or
((IV^.Specificity = MV^.Specificity) and (IV^.Order < MV^.Order)) then
Inc(I) else
break;
until False;
repeat
JV := @FMatches[J];
if (JV^.Specificity > MV^.Specificity) or
((JV^.Specificity = MV^.Specificity) and (JV^.Order > MV^.Order)) then
Dec(J) else
break;
until False;
if I <= J then
begin
Tmp := IV^;
IV^ := JV^;
JV^ := Tmp;
if M = I then
M := J else
if M = J then
M := I;
Inc(I);
Dec(J);
end;
until I > J;
if L < J then
QuickSort(L, J);
L := I;
until I >= R;
end;
var L: Integer;
begin
// Sort matches by specificity and order
L := FCount;
if L > 0 then
QuickSort(0, L - 1);
end;
procedure ThtmlcssMatchingDeclarations.ApplyStyleInfo(var StyleInfo: ThtmlcssStyleProperties;
const ParentStyle: ThtmlcssStyleProperties);
var I: Integer;
begin
for I := 0 to FCount - 1 do
FMatches[I].Declarations.ApplyStyleInfo(StyleInfo, ParentStyle);
end;
{ }
{ ThtmlcssRule }
{ }
constructor ThtmlcssRule.Create(const Selectors: ThtmlcssSelectors;
const Declarations: ThtmlcssDeclarations);
begin
inherited Create;
FSelectors := Selectors;
FDeclarations := Declarations;
end;
destructor ThtmlcssRule.Destroy;
begin
FreeAndNil(FDeclarations);
FreeAndNil(FSelectors);
inherited Destroy;
end;
procedure ThtmlcssRule.AddMatch(const ElementInfo: ThtmlcssElementInfo;
const Matches: ThtmlcssMatchingDeclarations);
var Selector: ThtmlcssSelector;
begin
Selector := FSelectors.MatchingSelector(ElementInfo);
if not Assigned(Selector) then
// rule selector does not match
exit;
// add match
Matches.AddMatch(Selector.Specificity, FDeclarations);
end;
{ }
{ ThtmlcssRuleSet }
{ }
constructor ThtmlcssRuleSet.Create(const CSS: ThtmlCSS;
const State: ThtmlcssRuleSetState; const Source: String);
begin
inherited Create;
FCSS := CSS;
FState := State;
FSource := Source;
end;
destructor ThtmlcssRuleSet.Destroy;
var I, N: ThtmlcssRule;
begin
I := FFirst;
while Assigned(I) do
begin
N := I.FNext;
I.Free;
I := N;
end;
inherited Destroy;
end;
procedure ThtmlcssRuleSet.AddRule(const Rule: ThtmlcssRule);
begin
if not Assigned(FFirst) then
FFirst := Rule;
if Assigned(FLast) then
FLast.FNext := Rule;
FLast := Rule;
Rule.FNext := nil;
end;
procedure ThtmlcssRuleSet.AddImport(const Source: String);
begin
DynArrayAppend(ObjectArray(FImports), ThtmlcssRuleSet.Create(FCSS, rsNotImported, Source));
end;
procedure ThtmlcssRuleSet.GetRequiredImports(var Sources: StringArray);
var S: String;
I: Integer;
begin
if FState = rsNotImported then
begin
S := FSource;
StrTrimInPlaceU(S);
if (S <> '') and (PosNextNoCaseU(S, Sources, -1, False) < 0) then
DynArrayAppend(Sources, S);
end;
for I := 0 to Length(FImports) - 1 do
FImports[I].GetRequiredImports(Sources);
end;
procedure ThtmlcssRuleSet.SetImportedStyleState(const Source: String;
const State: ThtmlcssRuleSetState; const StyleText: String);
var I: Integer;
begin
if (FState in [rsNotImported, rsBusyImporting]) and
StrEqualNoAsciiCaseU(Source, FSource) then
begin
FState := State;
if StyleText <> '' then
begin
FCSS.Parser.SetText(StyleText);
FCSS.Parser.ParseRules(self);
end;
end;
for I := 0 to Length(FImports) - 1 do
FImports[I].SetImportedStyleState(Source, State, StyleText);
end;
function ThtmlcssRuleSet.GetStyleSheetState: ThtmlcssStyleSheetState;
var I: Integer;
begin
case FState of
rsLocal,
rsImported : Result := ssReady;
rsBusyImporting : Result := ssBusyImporting;
rsImportFailed :
begin
Result := ssImportFailed;
exit;
end;
else
Result := ssNotImported;
end;
for I := 0 to Length(FImports) - 1 do
case FImports[I].GetStyleSheetState of
ssNotImported :
if Result = ssReady then
Result := ssNotImported;
ssReady : ;
ssBusyImporting :
if Result in [ssReady, ssNotImported] then
Result := ssBusyImporting;
ssImportFailed :
begin
Result := ssImportFailed;
exit;
end;
end;
end;
procedure ThtmlcssRuleSet.GetImportProgress(var StateVal, TotVal: Integer);
var I: Integer;
begin
case FState of
rsImported,
rsImportFailed :
begin
Inc(StateVal, 10);
Inc(TotVal, 10);
end;
rsBusyImporting :
begin
Inc(StateVal);
Inc(TotVal, 10);
end;
end;
for I := 0 to Length(FImports) - 1 do
FImports[I].GetImportProgress(StateVal, TotVal);
end;
procedure ThtmlcssRuleSet.GetMatches(const ElementInfo: ThtmlcssElementInfo;
const Matches: ThtmlcssMatchingDeclarations);
var Rule: ThtmlcssRule;
I: Integer;
begin
if FState in [rsNotImported, rsBusyImporting] then
exit;
// check imported rules (imported rules have lower cascade order)
for I := 0 to Length(FImports) - 1 do
FImports[I].GetMatches(ElementInfo, Matches);
// check rules
Rule := FFirst;
while Assigned(Rule) do
begin
Rule.AddMatch(ElementInfo, Matches);
Rule := Rule.FNext;
end;
end;
{ }
{ ThtmlCSS }
{ }
constructor ThtmlCSS.Create;
begin
inherited Create;
FClassIDs := THashedUnicodeStringArray.Create(False);
FElementIDs := THashedUnicodeStringArray.Create(True);
FRuleSet := ThtmlcssRuleSet.Create(self, rsLocal, '');
FMatches := ThtmlcssMatchingDeclarations.Create;
FParser := ThtmlcssParser.Create;
end;
destructor ThtmlCSS.Destroy;
begin
FreeAndNil(FParser);
FreeAndNil(FMatches);
FreeAndNil(FRuleSet);
FreeAndNil(FElementIDs);
FreeAndNil(FClassIDs);
inherited Destroy;
end;
function ThtmlCSS.AddClassID(const ClassID: String): Integer;
begin
Result := FClassIDs.AppendItem(ClassID);
end;
function ThtmlCSS.GetClassID(const ClassIDBuf: PWideChar; const ClassIDLen: Integer): Integer;
begin
if ClassIDLen <= 0 then
Result := -1
else
Result := FClassIDs.PosNext(ClassIDBuf); // ?
end;
function ThtmlCSS.GetClassID(const ClassID: String): Integer;
begin
Result := GetClassID(Pointer(ClassID), Length(ClassID));
end;
function ThtmlCSS.RequireClassID(const ClassIDBuf: PWideChar; const ClassIDLen: Integer): Integer;
var S: String;
begin
if ClassIDLen <= 0 then
begin
Result := -1;
exit;
end;
Result := GetClassID(ClassIDBuf, ClassIDLen);
if Result >= 0 then
exit;
SetLength(S, ClassIDLen);
Move(ClassIDBuf^, Pointer(S)^, ClassIDLen * SizeOf(WideChar));
Result := AddClassID(S);
end;
function ThtmlCSS.RequireClassID(const ClassID: String): Integer;
begin
Result := RequireClassID(Pointer(ClassID), Length(ClassID));
end;
function ThtmlCSS.GetElementID(const ElementID: String): Integer;
begin
if ElementID = '' then
Result := -1
else
Result := FElementIDs.PosNext(ElementID);
end;
function ThtmlCSS.AddElementID(const ElementID: String): Integer;
begin
Result := FElementIDs.AppendItem(ElementID);
end;
function ThtmlCSS.RequireElementID(const ElementID: String): Integer;
begin
if ElementID = '' then
begin
Result := -1;
exit;
end;
Result := GetElementID(ElementID);
if Result >= 0 then
exit;
Result := AddElementID(ElementID);
end;
procedure ThtmlCSS.InitStyle(const ReaderStyleText, DocumentStyleText: String;
DocumentStyleRef: StringArray);
var I : Integer;
begin
// Init Reader style (lower cascading order than Document style)
if ReaderStyleText <> '' then
begin
FParser.SetText(ReaderStyleText);
FParser.ParseRules(FRuleSet);
end;
// Init Document style
for I := 0 to Length(DocumentStyleRef) - 1 do
FRuleSet.AddImport(DocumentStyleRef[I]);
if DocumentStyleText <> '' then
begin
FParser.SetText(DocumentStyleText);
FParser.ParseRules(FRuleSet);
end;
end;
function ThtmlCSS.GetRequiredImports: StringArray;
begin
Result := nil;
FRuleSet.GetRequiredImports(Result);
end;
procedure ThtmlCSS.SetImportedStyleState(const Source: String;
const State: ThtmlcssRuleSetState; const StyleText: String);
begin
FRuleSet.SetImportedStyleState(Source, State, StyleText);
end;
function ThtmlCSS.GetStyleSheetState: ThtmlcssStyleSheetState;
begin
Result := FRuleSet.GetStyleSheetState;
end;
function ThtmlCSS.GetImportProgress: Integer;
var I, J: Integer;
begin
I := 0;
J := 0;
FRuleSet.GetImportProgress(I, J);
if J = 0 then
Result := 100
else
Result := Round(I / J * 100.0);
end;
function ThtmlCSS.ParseDeclarations(const Text: String): ThtmlcssDeclarations;
begin
FParser.SetText(Text);
Result := FParser.ParseDeclarations;
end;
procedure ThtmlCSS.ApplyStyleInfo(var StyleInfo: ThtmlcssStyleProperties;
const ParentStyle: ThtmlcssStyleProperties; const ElementInfo: ThtmlcssElementInfo);
begin
FMatches.Clear;
FRuleSet.GetMatches(ElementInfo, FMatches);
if FMatches.Count > 0 then
begin
FMatches.Sort;
FMatches.ApplyStyleInfo(StyleInfo, ParentStyle);
end;
end;
{ }
{ ThtmlcssParser }
{ }
const
htmlcssWhiteSpace = [#0..#32];
htmlcssNameChar = ['a'..'z', 'A'..'Z', '-', '0'..'9', '_'];
procedure ThtmlcssParser.Init;
begin
FDataPos := 0;
end;
procedure ThtmlcssParser.InitBuf(const Buf: Pointer; const Size: Integer);
begin
FData := Buf;
FDataSize := Size;
FText := '';
Init;
end;
procedure ThtmlcssParser.InitText(const Text: String);
begin
FText := Text;
FData := Pointer(FText);
FDataSize := Length(FText);
Init;
end;
procedure ThtmlcssParser.SetText(const Text: String);
begin
InitText(Text);
end;
function ThtmlcssParser.GetBuf(var Buf: PWideChar; var Size: Integer): Boolean;
var I, L: Integer;
begin
I := FDataPos;
L := FDataSize;
if I < L then
begin
// Data available
Buf := FData;
Inc(Buf, I);
Size := L - I;
Result := True;
end
else
begin
// EOF
Buf := nil;
Size := 0;
Result := False;
end;
end;
function ThtmlcssParser.SkipSpace(var P: PWideChar): Integer;
begin
Result := 0;
Inc(Result, StrZSkipAllW(P, htmlcssWhiteSpace));
while StrPMatchStrU(P, 2, '/*') do // comment
begin
Inc(P, 2);
Inc(Result, 2);
Inc(Result, StrZSkipToStrU(P, '*/', True));
Inc(P, 2);
Inc(Result, 2);
Inc(Result, StrZSkipAllW(P, htmlcssWhiteSpace));
end;
end;
function ThtmlcssParser.ParseDeclaration: ThtmlcssProperty;
var P, Q: PWideChar;
L, M, N: Integer;
PropID: ThtmlcssPropertyID;
Value: String;
Imp: Boolean;
begin
Result := nil;
if not GetBuf(P, M) then
exit;
L := M;
try
// Name
Dec(L, SkipSpace(P));
if L <= 0 then
exit;
Q := P;
N := StrZSkipAllW(P, htmlcssNameChar);
if N = 0 then
exit;
PropID := htmlcssGetPropertyIDPtrW(Q, N);
Dec(L, N);
if L <= 0 then
exit;
// Value
Dec(L, SkipSpace(P));
if L <= 0 then
exit;
if P^ <> ':' then
exit;
Inc(P);
Dec(L);
Dec(L, SkipSpace(P));
if L <= 0 then
exit;
Value := StrZExtractToU(P, [';', '!', '}']);
Dec(L, Length(Value));
if L < 0 then
exit;
StrTrimInPlaceU(Value, htmlcssWhiteSpace);
Imp := False;
if P^ = '!' then
begin
Inc(P);
Dec(L);
while (L > 0) and not WideCharInCharSet(P^, [';', '}']) do
begin
Dec(L, SkipSpace(P));
if L <= 0 then
break;
Q := P;
N := StrZSkipAllW(P, htmlcssNameChar);
if (N = 9) and StrPMatchNoAsciiCaseW(Q, 'important', 9) then
Imp := True;
Dec(L, N);
end;
end;
Result := htmlcssGetPropertyClass(PropID).Create(PropID, Value, Imp);
finally
Inc(FDataPos, M - L);
end;
end;
function ThtmlcssParser.ParseDeclarations: ThtmlcssDeclarations;
var Decl : ThtmlcssProperty;
P : PWideChar;
L : Integer;
begin
Result := nil;
repeat
// parse declaration
Decl := ParseDeclaration;
if Assigned(Decl) then
begin
if not Assigned(Result) then
Result := ThtmlcssDeclarations.Create;
Result.AddDeclaration(Decl);
end;
// skip to start of next declaration
if not GetBuf(P, L) then
exit;
Inc(FDataPos, StrZSkipToCharW(P, [';', '}']));
if P^ = ';' then
Inc(FDataPos)
else
break;
until False;
end;
const
SelectorStartChar = htmlcssNameChar + ['#', ':', '.'];
function ThtmlcssParser.ParseSelector(const RuleSet: ThtmlcssRuleSet): ThtmlcssSelector;
var P, Q : PWideChar;
L, M, N : Integer;
TagID: ThtmlTagID;
IDStr: String;
PPIDs: ThtmlcssPseudoPropertyIDSet;
PPID: ThtmlcssPseudoPropertyID;
ClassID: Integer;
OuterSel: ThtmlcssSelector;
begin
Result := nil;
if not GetBuf(P, M) then
exit;
L := M;
try
Dec(L, SkipSpace(P));
if L <= 0 then
exit;
OuterSel := nil;
repeat
// tag name
Q := P;
N := StrZSkipAllW(P, htmlcssNameChar);
if N > 0 then
begin
Dec(L, N);
TagID := htmlGetTagIDPtrW(Q, N);
end
else
TagID := HTML_TAG_None;
IDStr := '';
PPIDs := [];
ClassID := -1;
repeat
case P^ of
'#' :
begin
Inc(P);
Dec(L);
Dec(L, SkipSpace(P)); // space actually not allowed here
// parse id
IDStr := StrZExtractAllU(P, htmlcssNameChar);
Dec(L, Length(IDStr));
end;
':' :
begin
Inc(P);
Dec(L);
Dec(L, SkipSpace(P)); // space actually not allowed here
// parse pseudo-class id
Q := P;
N := StrZSkipAllW(P, htmlcssNameChar);
if N > 0 then
begin
Dec(L, N);
PPID := htmlcssGetPseudoPropIDPtrW(Q, N);
if PPID <> HTML_CSS_PP_None then
Include(PPIDs, PPID);
end;
end;
'.' :
begin
Inc(P);
Dec(L);
Dec(L, SkipSpace(P)); // space actually not allowed here
// parse class id
Q := P;
N := StrZSkipAllW(P, htmlcssNameChar);
if N > 0 then
begin
Dec(L, N);
ClassID := RuleSet.CSS.RequireClassID(Q, N);
end;
end;
else
break;
end;
until (L <= 0) or WideCharInCharSet(P^, htmlcssWhiteSpace);
if (TagID = HTML_Tag_None) and (IDStr = '') and (PPIDs = []) and
(ClassID = -1) then
begin
// no more selectors
Result := OuterSel;
break;
end
else
begin
if (TagID = HTML_TAG_None) and (PPIDs * HTML_CSS_PP_Properties_Anchor <> []) then
TagID := HTML_TAG_A;
Result := ThtmlcssSelector.Create(TagID, ClassID,
RuleSet.CSS.RequireElementID(IDStr), PPIDs, OuterSel);
OuterSel := Result;
end;
Dec(L, SkipSpace(P));
until (L <= 0) or not WideCharInCharSet(P^, SelectorStartChar);
finally
Inc(FDataPos, M - L);
end;
end;
function ThtmlcssParser.ParseSelectors(const RuleSet: ThtmlcssRuleSet): ThtmlcssSelectors;
var Sel: ThtmlcssSelector;
P: PWideChar;
L: Integer;
begin
Result := nil;
repeat
// parse selector
Sel := ParseSelector(RuleSet);
if not Assigned(Sel) then
exit;
if not Assigned(Result) then
Result := ThtmlcssSelectors.Create;
Result.AddSelector(Sel);
// parse selector ',' seperator
if not GetBuf(P, L) then
exit;
Inc(FDataPos, SkipSpace(P));
if P^ <> ',' then
exit;
Inc(FDataPos);
until False;
end;
function ThtmlcssParser.ParseRule(const RuleSet: ThtmlcssRuleSet): ThtmlcssRule;
var Sel: ThtmlcssSelectors;
Decl: ThtmlcssDeclarations;
P, Q: PWideChar;
L: Integer;
S: String;
begin
Result := nil;
if not GetBuf(P, L) then
exit;
// @ rules
while P^ = '@' do
begin
Inc(P);
Inc(FDataPos);
Q := P;
L := StrZSkipToCharW(P, [';']);
Inc(FDataPos, L);
if (L > 0) and StrPMatchNoAsciiCaseW(Q, 'import ', 7) then
begin
// import rule
Inc(Q, 7);
SetLength(S, L - 7);
if L > 7 then
Move(Q^, Pointer(S)^, (L - 7) * SizeOf(WideChar));
RuleSet.AddImport(S);
end;
Inc(P);
Inc(FDataPos);
Inc(FDataPos, SkipSpace(P));
end;
// parse selectors
Sel := ParseSelectors(RuleSet);
if GetBuf(P, L) then
begin
// skip to start of declaration (skip unknown characters in selector)
Inc(FDataPos, StrZSkipToCharW(P, ['{']));
Inc(FDataPos);
// parse declarations
Decl := ParseDeclarations;
end else
Decl := nil;
if GetBuf(P, L) then
begin
// skip to end of rule (skip unknown characters in declarations)
Inc(FDataPos, StrZSkipToCharW(P, ['}']));
Inc(FDataPos);
end;
// create rule
if not Assigned(Sel) or not Assigned(Decl) then
begin
Sel.Free;
Decl.Free;
Result := nil;
exit;
end;
Result := ThtmlcssRule.Create(Sel, Decl);
end;
procedure ThtmlcssParser.ParseRules(const RuleSet: ThtmlcssRuleSet);
var Rule : ThtmlcssRule;
P : PWideChar;
L : Integer;
begin
repeat
// parse rule
Rule := ParseRule(RuleSet);
if Assigned(Rule) then
RuleSet.AddRule(Rule);
// skip to start of next rule
if not GetBuf(P, L) then
exit;
Inc(FDataPos, SkipSpace(P));
until FDataPos >= FDataSize;
end;
end.