stylepars.pas

查看html文件的控件

{ do the List-Style shorthand property specifier }
var
  S: array[0..6] of string;
  Count, I: integer;

begin
SplitString(Value, S, Count);
for I := 0 to Count-1 do
  begin
  if Pos('url(', S[I]) > 0 then
    begin
    if LinkPath <> '' then  {path added now only for <link...>}
      S[I] := AddPath(S[I]);
    Process(Styles, Selectors, 'list-style-image', S[I])
    end
  else Process(Styles, Selectors, 'list-style-type', S[I]);
  {should also do List-Style-Position }
  end;
end;

{----------------DoMarginItems}
procedure DoMarginItems(X: ShortIndex; Styles: TObject; Selectors: TStringList;
          Prop, Value: string; Process: TProcessProc);
{ Do the Margin, Border, Padding shorthand property specifiers}
var
  S: array[0..3] of string;
  I, Count : integer;
  Index: array[0..3] of PropIndices;

  procedure DoIndex(ix: PropIndices; const AValue: string);
  begin
  Process(Styles, Selectors, PropWords[ix], AValue);
  end;

begin
if Value = '' then Exit;

SplitString(Value, S, Count);  {split Value into parts}

case X of
  MarginX: Index[0] := MarginTop;
  PaddingX: Index[0] := PaddingTop;
  BorderWidthX: Index[0] := BorderTopWidth;
  BorderColorX: Index[0] := BorderTopColor;  
  BorderStyleX: Index[0] := BorderTopStyle;   
  end;

for I := 1 to 3 do
  Index[I] := Succ(Index[I-1]);

DoIndex(Index[0], S[0]);
case Count of
  1: for I := 1 to 3 do
     DoIndex(Index[I], S[0]);
  2: begin
     DoIndex(Index[2], S[0]);
     DoIndex(Index[1], S[1]);
     DoIndex(Index[3], S[1]);
     end;
  3: begin
     DoIndex(Index[2], S[2]);
     DoIndex(Index[1], S[1]);
     DoIndex(Index[3], S[1]);
     end;
  4: begin
     DoIndex(Index[1], S[1]);
     DoIndex(Index[2], S[2]);
     DoIndex(Index[3], S[3]);
     end;
  end;
end;

{----------------SortContextualItems}
function SortContextualItems(S: string): string;    
{Put a string of contextual items in a standard form for comparison purposes.
 div.ghi#def:hover.abc
   would become
 div.abc.ghi:hover#def
 Enter with S as lowercase
}
const
  Eos = #0;
var
  Ch, C: char;
  SS: string;
  SL: TStringList;
  Done: boolean;
  I: integer;

  procedure GetCh;
  begin
  if I <= Length(S) then
    Ch := S[I]
  else Ch := Eos;
  Inc(I);
  end;

begin
Result := '';
SL := TStringList.Create;   {TStringlist to do sorting}
try
  SL.Sorted := True;
  Done := False;
  I := 1;
  GetCh;
  while not done do
    begin
    if Ch = Eos then
      Done := True
    else
      begin
      case Ch of   {add digit to sort item}
        '.': C := '1';
        ':': C := '2';
        '#': C := '3';
        else C := '0';
        end;
      SS := C+Ch;
      GetCh;
      while Ch in ['a'..'z', '0'..'9', '_', '-'] do
        begin
        SS := SS+Ch;
        GetCh;
        end;
      SL.Add(SS);
      end;
    end;
  for I := 0 to SL.Count-1 do
    Result := Result+Copy(SL.Strings[I], 2, Length(SL.Strings[I])-1);
finally
  SL.Free;
  end;
end;

{----------------GetSelectors}
procedure GetSelectors(Styles: TStyleList; Selectors: TStringList);
{Get a series of selectors seperated by ',', like:  H1, H2, .foo }
var
  S: string;
  Sort: Boolean;
  Cnt: integer;

  function FormatContextualSelector(S: string; Sort: boolean): string;
  {Takes a contextual selector and reverses the order.  Ex: 'div p em' will
   change to 'em Np div'.   N is a number added.  The first digit of N is
   the number of extra selector items.  The remainder of the number is a sequnce
   number which serves to sort entries by time parsed.}
  var
    I, Cnt: integer;
    Tmp: string;

    function DoSort(St: string): string;    
    begin
    if Sort then
      Result := SortContextualItems(St)
    else Result := St;
    end;

  begin
  Result := '';
  Cnt := 0;
  I := Pos(' ', S);
  if (I > 0) and (Cnt <= 8) then
    begin
    while I > 0 do
      begin
      Inc(Cnt);
      Insert(DoSort(Copy(S, 1, I-1))+' ', Result, 1);
      S := Trim(Copy(S, I+1, Length(S)));
      I := Pos(' ', S);
      end;
    if S <> '' then
      Result := DoSort(S)+' '+Result;
    I := Pos(' ', Result);
    Str(Cnt, Tmp);
    Insert(Tmp+Styles.GetSeqNo, Result, I+1);
    end
  else Result := DoSort(S);
  end;

begin
repeat
  if LCh = ',' then
    GetCh;
  SkipWhiteSpace;
  S := '';
  Sort := False;
  Cnt := 0;
  while LCh in ['A'..'Z', 'a'..'z', '0'..'9', ' ', '.', ':', '#', '-', '_'] do
    begin
    case LCh of     
      '.', ':', '#':  {2 or more of these in an item will require a sort to put
                       in standard form}
            begin
            Inc(Cnt);
            if Cnt = 2 then
              Sort := True;
            end;
      ' ':  Cnt := 0;
      end;
    S := S+LCh;
    GetCh;
    end;
  S := Trim(Lowercase(S));
  S := FormatContextualSelector(S, Sort);
  Selectors.Add(S);
until LCh <> ',';
while not (LCh in ['{', '<', EofChar]) do
  GetCh;
end;

{----------------GetCollection}
procedure GetCollection(Styles: TStyleList; Selectors: TStringList);
//Read a series of property, value pairs such as "Text-Align: Center;" between
//  '{', '}'  brackets. Add these to the Styles list for the specified selectors
var
  Prop, Value, Value1: string;
  Index: ShortIndex;
begin
if LCh <> '{' then Exit;
GetCh;
repeat
  Prop := '';
  SkipWhiteSpace;
  while LCh in ['A'..'Z', 'a'..'z', '0'..'9', '-'] do
    begin
    Prop := Prop+LCh;
    GetCh;
    end;
  Prop := Trim(LowerCase(Prop));
  SkipWhiteSpace;
  if LCh in [':', '='] then
    begin
    GetCh;
    Value := '';
    while not (LCh in [';', '}', '<', EofChar]) do
      begin
      Value := Value+LCh;
      GetCh;
      end;
    Value1 := Trim(Lowercase(Value));  {leave quotes on for font:}
    Value := RemoveQuotes(Value1);
    if FindShortHand(Prop, Index) then
      case Index of
        MarginX, BorderWidthX, PaddingX, BorderColorX, BorderStyleX:     
          DoMarginItems(Index, Styles, Selectors, Prop, Value, ProcessProperty);
        FontX:
          DoFont(Styles, Selectors, Prop, Value1, ProcessProperty);
        BackgroundX:
          DoBackground(Styles, Selectors, Prop, Value, ProcessProperty);
        ListStyleX:
          DoListStyle(Styles, Selectors, Prop, Value, ProcessProperty);
        BorderX..BorderLX:
          DoBorder(Styles, Selectors, Prop, Value, ProcessProperty);
        end
    else
      begin
      if (LinkPath <> '') and (Pos('url(', Value) > 0) then
        Value := AddPath(Value);
      ProcessProperty(Styles, Selectors, Prop, Value);
      end;
    end;
  SkipWhiteSpace;
  if LCh = ';' then
    GetCh;
  while not (LCh in ['A'..'Z', 'a'..'z', '0'..'9', '-', '}', '<', EofChar]) do    
    GetCh;
until LCh in ['}', '<', EofChar];
if LCh = '}' then
  GetCh;
end;

{----------------DoStyle}
procedure DoStyle(Styles: TStyleList; var C: char; GC: CharFunction;
             const APath: string; FromLink: boolean);
var
  Selectors: TStringList;

  procedure ReadAt; {read thru @import or some other @}
  var
    Media: string;

    procedure Brackets;
    begin
    if Pos('screen', Lowercase(Media)) > 0 then
      begin    {parse @ media screen  }
      GetCh;
      repeat
        Selectors.Clear;
        GetSelectors(Styles, Selectors);
        GetCollection(Styles, Selectors);
        SkipWhiteSpace;
      until LCh  in ['}', '<', EOFChar];
      end
    else
      repeat     // read thru nested '{...}' pairs
        GetCh;
        if LCh = '{' then
          Brackets;
      until LCh in ['}', '<', EOFChar];
    if LCh = '}' then
      GetCh;
    end;

  begin
  Media := '';     {read the Media string}
  repeat
    GetCh;
    Media := Media + LCh;
  until LCh in ['{', ';', '<', EOFChar];
  if LCh = '{' then
    Brackets
  else if LCh = ';' then
    GetCh;
  end;

begin
Get := GC;
LinkPath := APath;
{enter with the first character in C}
if C = ^M then
  C := ' ';

LCh := ' ';  {This trick is needed if the first char is part of comment, '/*'}
Back := C;

Selectors := TStringList.Create;

try
  while LCh in [' ', '<', '>', '!', '-'] do {'<' will probably be present from <style>}
    GetCh;
  repeat
    if LCh = '@' then
      ReadAt
    else if LCh = '<' then    
      begin   {someone left a tag here, ignore it}  
      repeat
        GetCh;
      until LCh in [' ', EOFChar];
      SkipWhiteSpace;
      end
    else
      begin
      Selectors.Clear;
      GetSelectors(Styles, Selectors);
      GetCollection(Styles, Selectors);
      end;
    while LCh in [' ', '-', '>'] do
      GetCh;
  until (LCh = EOFChar) or ((LCh = '<') and not FromLink); 
  C := UpCase(LCh);
finally
  Selectors.Free;
  end;
end;

// The following is to process the Style=  attribute strings

{----------------MyProcess}
procedure MyProcess(Propty: TObject; Selectors: TStringList; Prop, Value: string);
begin
(Propty as TProperties).AddPropertyByName(Prop, Value);
end;

{----------------ParsePropertyStr}
procedure ParsePropertyStr(const PropertyStr: string; var Propty: TProperties);
var
  Prop, Value, Value1, S: string;
  LCh: char;
  I: integer;
  Index: ShortIndex;

  procedure GetCh;
  begin
  if I <= Length(S) then
    begin
    LCh := S[I];
    Inc(I);
    if LCh = ^M then
      LCh := ' ';
    end
  else LCh := EofChar;
  end;

  Procedure SkipWhiteSpace;
  begin
  while (LCh in [' ']) do
    GetCh;
  end;

begin
LinkPath := '';
S := Lowercase(PropertyStr);
I := 1;
GetCh;
repeat
  Prop := '';
  SkipWhiteSpace;
  while LCh in ['A'..'Z', 'a'..'z', '0'..'9', '-'] do
    begin
    Prop := Prop+LCh;
    GetCh;
    end;
  Prop := Trim(Prop);
  SkipWhiteSpace;
  if LCh in [':', '='] then
    begin
    GetCh;
    Value := '';
    while not (LCh in [';', EofChar]) do
      begin
      Value := Value+LCh;
      GetCh;
      end;
    Value1 := Trim(Value);   {leave quotes on for font}
    Value := RemoveQuotes(Value1);

    if FindShortHand(Prop, Index) then
      case Index of
        MarginX, BorderWidthX, PaddingX, BorderColorX, BorderStyleX:   
          DoMarginItems(Index, Propty, Nil, Prop, Value, MyProcess);
        FontX:
          DoFont(Propty, Nil, Prop, Value1, MyProcess);
        BackgroundX:
          DoBackground(Propty, Nil, Prop, Value, MyProcess);
        BorderX..BorderLX:
          DoBorder(Propty, Nil, Prop, Value, MyProcess);
        ListStyleX:
          DoListStyle(Propty, Nil, Prop, Value, MyProcess);
        end
    else
      Propty.AddPropertyByName(Prop, Value);
    end;
  SkipWhiteSpace;
  if LCh = ';' then
    GetCh;
  while not (LCh in ['A'..'Z', 'a'..'z', '0'..'9', '-', EofChar]) do
    GetCh;
until LCh in [EofChar];
end;

end.