みなさんこんにちは。６番会議室 #28014 からのツリーで話題の
HTML Parser を書いてみました。toCommentTag のあたりが、ちょっち
ゴリゴリ臭いですが（笑）



---------------------------------------------------------------------
unit HParse;

{$V+,B-,X+,T-,P+,H+,J+}

interface

{ THParser }

const
  toEof        = Char(0);
  toTag        = Char(25); { <xxxx }
  toOption     = Char(26); { xxxxxx }
  toParam      = Char(27); { ="xxxx" }
  toEndTag     = Char(28); { </xxxx> }
  toCommentTag = Char(29); { <!-- xx --> }
  toContext    = Char(30); { xxxx }

type
  THParser = class(TObject)
  protected
    FBuffer: PChar;
    FBufSize: Integer;
    FInTag: Boolean;
    FSourcePtr: PChar;
    FTokenPtr: PChar;
    FToken: Char;
    procedure SkipBlanks; virtual;
  public
    constructor Create(const S: String);
    destructor Destroy; override;
    function NextToken: Char; virtual;
    function SourcePos: Longint;
    function TokenString: String;
    property Token: Char read FToken;
  end;

implementation

{ THParser }

constructor THParser.Create(const S: String);
begin
  FBufSize := Length(S);
  GetMem(FBuffer, FBufSize + 1);
  if FBufSize > 0 then
    Move(S[1], FBuffer[0], FBufSize);
  FBuffer[FBufSize] := #0;
  FSourcePtr := FBuffer;
  FTokenPtr := FBuffer;
  NextToken;
end;

destructor THParser.Destroy;
begin
  if FBuffer <> nil then
    FreeMem(FBuffer, FBufSize + 1);
end;

procedure THParser.SkipBlanks;
begin
  while True do
  begin
    case FSourcePtr^ of
      #0:
        Exit;
      #33..#255:
        Exit;
    end;
    Inc(FSourcePtr);
  end;
end;

function THParser.SourcePos: Longint;
begin
  Result := FTokenPtr - FBuffer;
end;

function THParser.TokenString: string;
begin
  SetString(Result, FTokenPtr, FSourcePtr - FTokenPtr);
end;

function THParser.NextToken: Char;
var
  P: PChar;
begin
  SkipBlanks;
  P := FSourcePtr;
  FTokenPtr := P;
  if not FInTag then
    case P^ of
      '<':
        begin
          Inc(P);
          case P^ of
            '!':
              begin
                if Copy(String(P), 1, 3) = '!--' then
                begin
                  Result := toCommentTag;
                  Inc(P);
                  while True do
                  begin
                    if (P^ = #0) or
                       ((P^ = '-') and
                        (Copy(String(P), 1, 3) = '-->')) then
                    begin
                      while not (P^ in [#0, '>']) do Inc(P);
                      Break;
                    end;
                    Inc(P);
                  end;
                  if P^ = '>' then Inc(P);
                end
                else
                  Result := '<';
              end;
            '/':
              begin
                Result := toEndTag;
                while not (P^ in [#0, '>']) do Inc(P);
                if P^ = '>' then Inc(P);
              end;
            'A'..'Z', 'a'..'z':
              begin
                Result := toTag;
                FInTag := True;
                while P^ in ['A'..'Z', 'a'..'z'] do Inc(P);
              end;
          else
            Result := '<';
          end;
        end;
      #33..#59, #61..#255:
        begin
          Result := toContext;
          while not (P^ in [#0, '<']) do Inc(P);
        end;
    else
      Result := P^;
      if Result <> toEof then Inc(P);
    end
  else
  begin
    case P^ of
      'A'..'Z', 'a'..'z':
        begin
          Inc(P);
          Result := toOption;
          while P^ in ['A'..'Z', 'a'..'z'] do Inc(P);
        end;
      '=':
        begin
          Inc(P);
          Result := toParam;
          if P^ = '"' then
          begin
            Inc(P);
            while not (P^ in [#0, '"']) do Inc(P);
            if P^ = '"' then Inc(P);
          end
          else
            while P^ in [#33..#59, #61, #63..#126] do Inc(P);
        end;
    else
      Result := P^;
      if Result <> toEof then Inc(P);
    end;
    if Result in ['<', '>'] then FInTag := False;
  end;
  FSourcePtr := P;
  FToken := Result;
end;

end.
---------------------------------------------------------------------
使い方
Memo1 に適当な html 文を入れておき、Memo2 にトークンを取り出します。

uses
  HParse;
  
procedure TForm1.Button1Click(Sender: TObject);
var
  Parser: THParser;
  S: String;
begin
  Memo2.Lines.Clear;
  Memo2.Lines.BeginUpdate;
  try
    Parser := THParser.Create(Memo1.Lines.Text);
    try
      while Parser.Token <> toEof do
      begin
        case Parser.Token of
          toTag:        S := 'Tag     :';
          toOption:     S := 'Option  :';
          toParam:      S := 'Param   :';
          toEndTag:     S := 'EndTag  :';
          toCommentTag: S := 'Comment :';
          toContext:    S := 'Context :';
        else
          S := Format('%-8s:', [Parser.Token]);
        end;
        Memo2.Lines.Add(S + Parser.TokenString);
        Parser.NextToken;
      end;
    finally
      Parser.Free;
    end;
  finally
    Memo2.Lines.EndUpdate;
  end;
end;

このトークンを元に木を作るワケですが、木の仕様によっては、
トークンの切り出し方を変更する必要があるかもしれませんね。

ご意見がありましたら、６番会議室の方へお願いします。m(_ _)m

///// 本田勝彦 http://member.nifty.ne.jp/~katsuhiko/ /////

Original document by 本田勝彦        氏 ID:(VYR01647)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。