readhtml.pas

查看html文件的控件

procedure PopAProp(Tag: string);
{pop and free a TProperties from the Prop stack.  It should be on top but in
 case of a nesting error, find it anyway}
var
  I, J: integer;
begin
for I := PropStackIndex downto 1 do
  if PropStack[I].Proptag = Tag then
    begin
    if PropStack[I].GetBorderStyle <> bssNone then
      {this would be the end of an inline border}
      MasterList.ProcessInlines(SIndex, PropStack[I], False);  
    PropStack.Delete(I);
    if I > 1 then      {update any stack items which follow the deleted one}
      for J := I to PropStackIndex do
        PropStack[J].Update(PropStack[J-1], MasterList.Styles, J);
    Break;
    end;
end;

procedure DoTextArea(TxtArea: TTextAreaFormControlObj);
{read and save the text for a TextArea form control}
var
  S: string;
  Token: string;

  procedure Next1;
    {Special Next routine to get the next token}
    procedure GetTag1;  {simplified Pick up a Tag routine}
    begin
    Token := '<';
    GetCh;
    Sy := CommandSy;
    while not (LCh in [' ', ^M, Tab, '>']) do
      begin
      Token := Token + LCh;
      GetCh;
      end;
    if CompareText(Token, '</textarea') = 0 then
      Sy := TextAreaEndSy
    else Sy := CommandSy;    {anything else}
    end;

    function IsText1 : boolean;
    begin
    while (Length(Token) < 100) and  not (LCh in [^M, '<', '&', EofChar]) do
      begin
      Token := Token+LCh;
      GetCh;
      end;
    if Length(Token) > 0 then
      begin
      Sy := TextSy;
      IsText1 := True;
      end
    else IsText1 := False;
    end;

  begin  {already have fresh character loaded here}
  Token := '';
  LCToken.Clear;     
  if LCh = EofChar then Sy := EofSy
  else if LCh = ^M then
    begin
    Sy := EolSy;
    GetCh;
    end
  else if LCh = '<' then
     begin GetTag1;  Exit;  end
  else if LCh = '&' then
    begin
    if UnicodeControls then    
      Token := Token + GetEntityStr(PropStack.Last.CodePage)
    else
      Token := Token + GetEntityStr(CP_ACP);  
    Sy := CommandSy;
    end
  else if IsText1 then
  else
    begin
    Sy := OtherChar;
    Token := LCh;
    GetCh;
    end;
  end;

begin
Next1;
S := '';
while (Sy <> TextAreaEndSy) and (Sy <> EofSy) do
  begin
  case Sy of
    TextSy: S := S + Token;
    EolSy:
      begin
      S := S+^M+^J;
      TxtArea.AddStr(S);
      S := '';
      end;
    else
      S := S + Token;
    end;
  Next1;
  end;
while not (LCh in ['>', EofChar]) do
  GetCh; {remove chars to and past '>'}
GetCh;
if S <> '' then TxtArea.AddStr(S);
TxtArea.ResetToValue;
end;

function FindAlignment: string;  {pick up Align= attribute}
var
  T: TAttribute;
  S: string;
begin
Result := '';
if Attributes.Find(AlignSy, T) then
  begin
  S := LowerCase(T.Name);
  if (S = 'left') or (S = 'center') or (S = 'right') or (S = 'justify') then   
    Result := S
  else if S = 'middle' then   
    Result := 'center';
  end;
end;

procedure CheckForAlign;
var
  S: string;
begin
S := FindAlignment;
if S <> '' then
  PropStack.Last.Assign(S, TextAlign);
end;

type
  SymbSet = Set of Symb;
const
  TableTermSet = [TableEndSy, TDSy, TRSy, TREndSy, THSy, THEndSy, TDEndSy,
                  CaptionSy, CaptionEndSy, ColSy, ColgroupSy];

procedure DoBody(const TermSet: SymbSet); forward;

procedure DoLists(Sym: Symb; const TermSet: SymbSet); forward;

procedure DoAEnd;  {do the </a>}
begin
if InHref then   {see if we're in an href}
  begin
  CurrentUrlTarget.SetLast(ThtmlViewer(CallingObject).LinkList, SIndex);  
  CurrentUrlTarget.Clear;
  InHref := False;
  end;
PopAProp('a');
if Assigned(Section) then
  Section.HRef(AEndSy, MasterList, CurrentUrlTarget, Nil, PropStack.Last);
end;

procedure DoDivEtc(Sym: Symb; const TermSet: SymbSet);
var
  FormBlock, DivBlock: TBlock;    
begin
case Sym of
  DivSy:
    begin
    SectionList.Add(Section, TagIndex);
    PushNewProp('div', Attributes.TheClass, Attributes.TheID, '', Attributes.TheTitle, Attributes.TheStyle);
    CheckForAlign;

    DivBlock := TBlock.Create(MasterList, PropStack.Last, SectionList, Attributes);
    SectionList.Add(DivBlock, TagIndex);
    SectionList := DivBlock.MyCell;

    Section := TSection.Create(MasterList, Nil, PropStack.Last,
               CurrentUrlTarget, SectionList, True);
    Next;
    DoBody([DivEndSy]+TermSet);
    SectionList.Add(Section, TagIndex);
    PopAProp('div');
    if SectionList.CheckLastBottomMargin then     
      begin
      DivBlock.MargArray[MarginBottom] := ParagraphSpace;   
      DivBlock.BottomAuto := True;
      end;
    SectionList := DivBlock.OwnerCell;

    Section := TSection.Create(MasterList, Nil, PropStack.Last,
               CurrentUrlTarget, SectionList, True);
    if Sy in [DivEndSy] then
      Next;
    end;
  CenterSy:
    begin
    SectionList.Add(Section, TagIndex);
    PushNewProp('center', '', '', '', '', Nil);
    Section := Nil;
    Next;
    DoBody([CenterEndSy]+TermSet);
    SectionList.Add(Section, TagIndex);
    PopAProp('center');
    Section := Nil;
    if Sy in [CenterEndSy] then
      Next;
    end;
  FormSy:
    repeat
      SectionList.Add(Section, TagIndex);
      Section := Nil;
      PushNewProp('form', Attributes.TheClass, Attributes.TheID, '', Attributes.TheTitle, Attributes.TheStyle);
      FormBlock := TBlock.Create(MasterList, PropStack.Last, SectionList, Attributes);
      SectionList.Add(FormBlock, TagIndex);
      SectionList := FormBlock.MyCell;

      CurrentForm := ThtmlForm.Create(MasterList, Attributes);

      Next;
      DoBody(TermSet+[FormEndSy, FormSy]);

      SectionList.Add(Section, TagIndex);
      Section := Nil;
      PopAProp('form');
      if SectionList.CheckLastBottomMargin then     
        begin
        FormBlock.MargArray[MarginBottom] := ParagraphSpace;    
        FormBlock.BottomAuto := True;
        end;
      SectionList := FormBlock.OwnerCell;
      if Sy = FormEndSy then
        begin
        CurrentForm := Nil;
        Next;
        end;
    until Sy <> FormSy;  {in case <form> terminated by andother <form>}
  BlockQuoteSy, AddressSy:
    begin
    SectionList.Add(Section, TagIndex);
    Section := Nil;
    DoLists(Sy, TermSet+[BlockQuoteEndSy, AddressEndSy]);
    if Sy in [BlockQuoteEndSy, AddressEndSy] then  
      Next;
    end;
  else Next;
  end;
end;

type
  TCellManager = class(TStringList)
    Table: ThtmlTable;
    constructor Create(ATable: ThtmlTable);
    function FindColNum(Row: integer): integer;
    procedure AddCell(Row: integer; CellObj: TCellObj);
    end;
{TCellManager is used to keep track of the column where the next table cell is
 going when handling the <col> tag.  Because of colspan and rowspan attributes,
 this can be a messy process.  A StringList is used with a string for each
 row.  Initially, the string is filled with 'o's.  As each cell is added, 'o's
 are changed to 'x's in accordance with the sixe of the cell.
}
{----------------TCellManager.Create}
constructor TCellManager.Create(ATable: ThtmlTable);
begin
inherited Create;
Table := ATable;
end;

function TCellManager.FindColNum(Row: integer): integer;
{given the row of insertion, returns the column number where the next cell will
 go or -1 if out of range.  Columns beyond any <col> definitions are ignored}
begin
if Row = Count then
  Add(StringOfChar('o', Table.ColInfo.Count));
Result := Pos('o', Strings[Row])-1;
end;

procedure TCellManager.AddCell(Row: integer; CellObj: TCellObj);
{Adds this cell to the specified row}
var
  I, J, K, Span: integer;
  S1: string;
begin
{make sure there's enough rows to handle any RowSpan for this cell}
while Count < Row+CellObj.RowSpan do
  Add(StringOfChar('o', Table.ColInfo.Count));
I := Pos('o', Strings[Row]);    {where we want to enter this cell}
K := I;
if I > 0 then     {else it's beyond the ColInfo and we're not interested}
  for J := Row to Row+CellObj.RowSpan-1 do   {do for all rows effected}
    begin
    I := K;
    Span := CellObj.ColSpan;    {need this many columns for this cell}
    S1 := Strings[J];
    repeat
      if S1[I] = 'o' then
        begin
        S1[I] := 'x';
        Inc(I);
        Dec(Span);
        end
      else Break;
    until Span = 0;
    Strings[J] := S1;
    if Span > 0 then   {there's a conflict, adjust ColSpan to a practical value}
      Dec(CellObj.ColSpan, Span);
    end;
end;


{----------------DoColGroup}
procedure DoColGroup(Table: ThtmlTable; ColOK: boolean);
{reads the <colgroup> and <col> tags.  Put the info in ThtmlTable's ConInfo list}
var
  I, Span: integer;
  xWidth, cWidth: integer;
  xAsPercent, cAsPercent: boolean;
  xVAlign, cVAlign: AlignmentType;
  xAlign, cAlign: string;
  Algn: AlignmentType;

  procedure ReadColAttributes(var Width: integer; var AsPercent: boolean;
              var Valign: AlignmentType; var Align: string; var Span: integer);
  var
    I: integer;
  begin
  for I := 0 to Attributes.Count-1 do
    with TAttribute(Attributes[I]) do
      case Which of
        WidthSy:
          if Pos('%', Name) > 0 then
            begin
            if (Value > 0) and (Value <= 100) then Width := Value*10;
            AsPercent := True;
            end
          else Width := Value;
        AlignSy:
          begin
          Algn := AlignmentFromString(Name);
          if Algn in [ALeft, AMiddle, ARight, AJustify] then
            Align := Lowercase(Name);
          end;
        VAlignSy:
          begin
          Algn := AlignmentFromString(Name);
          if Algn in [ATop, AMiddle, ABottom, ABaseLine] then
            VAlign := Algn;
          end;
        SpanSy:
          Span := IntMax(1, Value);
        end;
  end;

begin
xWidth := 0;
xAsPercent := False;
xVAlign := ANone;
xAlign := '';
if Sy = ColGroupSy then
  begin
  if ColOk then
    ReadColAttributes(xWidth, xAsPercent, xVAlign, xAlign, Span);
  SkipWhiteSpace;
  Next;
  end;
while Sy = ColSy do
  begin
  if ColOK then
    begin
    {any new attributes in <col> will have priority over the <colgroup> items just read}
    cWidth := xWidth;     {the default values}
    cAsPercent := xAsPercent;
    cVAlign := xVAlign;
    cAlign := xAlign;
    Span := 1;
    ReadColAttributes(cWidth, cAsPercent, cVAlign, cAlign, Span);
    for I := 1 to IntMin(Span, 100) do
      Table.DoColumns(cWidth, cAsPercent, cVAlign, cAlign);
    end;
  SkipWhiteSpace;
  Next;
  end;
if Sy = ColGroupEndSy then
  Next;
end;

{----------------DoTable}
procedure DoTable;
var
  Table: ThtmlTable;
  SaveSectionList, JunkSaveSectionList: TCellBasic;
  SaveStyle: TFontStyles;
  SaveNoBreak: boolean;
  SaveListLevel: integer;       
  RowVAlign, VAlign: AlignmentType;
  Row: TCellList;
  CellObj: TCellObj;
  T: TAttribute;
  RowStack: integer;
  NewBlock: TTableBlock;
  SetJustify: JustifyType;
  CM: TCellManager;
  CellNum: integer;
  TdTh: string;
  ColOK: boolean;
  CaptionBlock: TBlock;
  CombineBlock: TTableAndCaptionBlock;
  TopCaption: boolean;
  RowType: TRowType; 
  HFStack: integer;  
  FootList: TList;  
  I: integer;   

  function GetVAlign(Default: AlignmentType): AlignmentType;
  var
    S: string[9];
    T: TAttribute;
  begin
  Result := Default;
  if Attributes.Find(VAlignSy, T) then
    begin
    S := LowerCase(T.Name);
    if (S = 'top') or (S = 'baseline') then Result := ATop
    else if S = 'middle' then Result := AMiddle
    else if (S = 'bottom') then Result := ABottom;
    end;
  end;

  procedure AddSection;
  begin
  if Assigned(SectionList) then
    begin
    SectionList.Add(Section, TagIndex);
    Section := Nil;
    if CellObj.Cell = SectionList then
      begin
      SectionList.CheckLastBottomMargin;
      Row.Add(CellObj);
      if Assigned(CM) then
        CM.AddCell(Table.Rows.Count, CellObj);
      end
    else
    {$ifdef DebugIt}
    ShowMessage('Table cell error, ReadHTML.pas, DoTable')
    {$endif}
    ;
    SectionList := Nil;
    end;
  end;

  procedure AddRow;   
  begin