////////////////////////////////////////////////////////////
//HTMLのテキストファイル編集ユニット
//00/05/17　リンクの種類によってMakeLinkListの返す値を変更しました
//00/07/31　MakeImgLinkのコードを追加しました。
//00/08/03
//      MakeImgListをBackgroundで指定された画像を列挙するように改造しました。
//      AddIndexhtml関数を追加しました。
//      StringAddReplaceIgnoreAllの説明をわかりやすくしました。
//00/08/04
//      PutSlashMark/RemoveSlashMarkを変更
//00/08/08
//      MakeImgListの実装を完全に変更
//      拡張子を含むテキスト検索で取得する方法に変えました
//      それに伴いAnsiPosRange関数なども含めました。
////////////////////////////////////////////////////////////
unit HtmlTxtCtrl;

interface

uses
  SysUtils, Classes, Dialogs, Math,
  DelimiterCut; //このユニットが必要です


type
  TTagRemainFlag = (trPerfect, trRemainCRLF, trTagCRLF);
  {TagRemainで使う
   trPerfect    完全にタグだけを残す(タグ外はCRLFもなくなる)
   trRemainCRLF タグ外のCRLFは削除しない
   trTagCRLF    終タグの後に常にCRLFを代入}

  TLinkList = (llFull, llExternal, llInternal, llMail);
  {MakeLinkListで使う
   llFull       すべてのリンクを列挙する
   llExternal   外部リンクを列挙する
   llInternal   内部リンクを列挙する
   llMail       メイルリンクを列挙する}

  TImgList = (ilFull, ilExternal, ilInternal);
  {MakeImgListで使う
   ilFuil       すべてのリンクを列挙する
   ilExternal   外部リンクを列挙する
   ilInternal   内部リンクを列挙する}


procedure MakeLinkList(const HtmlText: String; LinkList: TStrings;
 LinkListType: TLinkList);
//・HTMLファイルのリンクリストを作ります。
//　A HREFで指定されたURLのリストをTStringsに掘り込みます

procedure MakeImgList(const HtmlText: String; LinkList: TStrings;
 ImgListType: TImgList);
//・HTMLファイルのイメージリンクリストを作ります

function HTMLTagDelete(const HtmlText: String): String;
//・HTMLテキストからタグ<>で囲まれた部分を削除します
function TagDelete(const S, StartTag, EndTag: String): String;
//・テキストから任意のタグで囲まれた部分を削除

function HTMLTagRemain(const HtmlText: String;
 TagRemainFlag: TTagRemainFlag): String;
//・HTMLテキストからタグ<>で囲まれた以外の部分を削除します
function TagRemain(const S, StartTag, EndTag: String;
 TagRemainFlag: TTagRemainFlag): String;
//・テキストから任意のタグで囲まれた以外の部分を削除

function ExtractAbsoluteURL(const BaseURL, RelativeURL: string): string;
//URLの相対アドレスから絶対アドレスを求める

function AddIndexhtml(URL: String): String;
//フォルダ名URLなどにindex.htmlをつける


implementation

////////////////////////////////////////////////////////////
//ライブラリ内部共通関数
////////////////////////////////////////////////////////////

//Sの中にSubStrがいくつあるかカウントする
//大文字小文字は区別する
function StrCount(const Substr, S: string): Cardinal;
var
  Str: String;
begin
  Result := 0;
  if (Substr = '') or (S = '') then
  begin
    raise Exception.Create('カウント文字列不正エラー');
  end;

  Str := S;
  while AnsiPos( Substr, Str) <> 0 do
  begin
    Inc(Result);
    delete(Str, AnsiPos(Substr, Str), Length(Substr));
  end;
end;

//文字列の最後が'/'or'\'ならそれを取り除く
function RemoveSlashMark(const S: TFileName): TFileName;
begin
  Result := S;
  if Length(Result) = LastDelimiter('\/', Result) then
    SetLength(Result, Length(Result)-1);
end;

//文字列の最後が'\'なら'/'に置き換え
//それでも文字列の最後が'/'じゃないなら追加
function PutSlashMark(const S: TFileName): TFileName;
begin
  Result := RemoveSlashMark(S);
  Result := Result + '/';
end;

//AnsiPosの大小文字区別無し版
function AnsiIgnoreCasePos(const Substr, S: string): Integer;
begin
  Result := AnsiPos( AnsiUpperCase(Substr), AnsiUpperCase(S));
end;

//CRLF以外のものをDeleteする
//Deleteの範囲にCRLFが含まれている場合CRLFを後から追加
//CRのみLFのみには対応しない
procedure DeleteExceptCRLF(var s : AnsiString; index, count : Integer);
var
  i, CRLFCount: Integer;
begin
  CRLFCount := StrCount(#13#10, copy(s, index, count));
  Delete( S, index, count);
  for i := 0 to CRLFCount - 1 do
  begin
    Insert( #13#10, s, index);
  end;
end;


//-------------------------------
//特殊な置き換え関数
{
 文字列を追加して置き換える
 AAAという文字を検索してAAAxxxという値を代入します
 検索に大文字小文字は区別しません

 StringReplaceと何が違うかというと
 Result := StringReplace( Result, EndTag, EndTag+#13#10, [rfReplaceAll, rfIgnoreCase]);
 Result := StringAddReplaceIgnoreAll( Result, EndTag, #13#10);
 この↑のやり方ではEndTagの内容が
 大小文字が合わないのでStringAddReplaceEgnoreAllでは独自コーディングしています。
}

//
function StringAddReplaceIgnoreAll(const S, SearchPattern, AddPattern: String):
 String;
var
  i, LoopCount, FindIndex: Integer;
  Str: String;
begin
  Str := S;
  Result := '';

  LoopCount := StrCount( AnsiUpperCase(SearchPattern), AnsiUpperCase(S));

  for i := 0 to LoopCount - 1 do
  begin
    FindIndex := AnsiIgnoreCasePos( SearchPattern, Str);
    Insert(AddPattern, Str, FindIndex + Length(SearchPattern));
    Result := Result +
      copy(Str, 1, FindIndex + Length(SearchPattern)-1 + Length(AddPattern)-1);
    Delete(Str, 1, FindIndex + Length(SearchPattern)-1 + Length(AddPattern)-1);
  end;
  Result := Result + Str
end;

type TPosFunction = function(const Substr, S: string): Integer;
{typeはimplementation内で突然宣言してもOKだよ}

//-------------------------------
//指定範囲検索基本関数...これは直接使わない
function AnsiPosRangeBase(SearchFunc: TPosFunction;
 const SubStr, S: String; StartIndex, EndIndex: Integer): Integer;
var
  Str: String;
  FindIndex: Integer;
begin
  Result := 0;
  if (Substr = '') or (S = '') then exit;
  if not (StartIndex <= EndIndex) then exit;
  {↑↓見事なエラー処理だ}

  if (StartIndex < 1) then exit;
  if (Length(S) < EndIndex) then  EndIndex := Length(S);

{EndIndexだけはエラー処理を甘くしてみた。厳しくするなら↓のようにどうぞ}
//  if (StartIndex < 1) or (Length(S) < EndIndex) then exit;

  Str := copy(S, StartIndex, EndIndex - StartIndex + 1);

  FindIndex := SearchFunc( SubStr, Str);
  if FindIndex = 0 then
    Result := 0
  else
    Result := StartIndex + FindIndex - 1;
end;

//-------------------------------
//指定範囲を検索するAnsiPos
function AnsiPosRange(const SubStr, S: String;
 StartIndex, EndIndex: Integer): Integer;
begin
  Result := AnsiPosRangeBase(AnsiPos, SubStr, S, StartIndex, EndIndex);
end;

//-------------------------------
//指定範囲を検索するBackAnsiPos
function BackAnsiPosRange(const SubStr, S: String;
 StartIndex, EndIndex: Integer): Integer;
begin
  Result := AnsiPosRangeBase(BackAnsiPos, SubStr, S, StartIndex, EndIndex);
end;



////////////////////////////////////////////////////////////
//外部公開関数
////////////////////////////////////////////////////////////


//-------------------------------
//HTMLテキストからリンクリストを返す関数
//LinkListは関数外で生成しておくこと
//返す文字列は『URL｜リンク名』の形式
procedure MakeLinkList(const HtmlText: String; LinkList: TStrings;
 LinkListType: TLinkList);

    //-------------------------------
    //タグで指定された中身を取得する関数

    {タグが複数あっても先頭のFrontTag,BackTag一つしか認識しない
     タグの順番が逆とか片方が片方に含まれる場合は対応外
     "ABCD"などの文字列で前後タグが同じ文字列でもOK}
    function GetTagText(Body, StartTag, EndTag: String): String;
    begin
      Result := Body;

      if (AnsiIgnoreCasePos( StartTag, Result) = 0)
        or (AnsiIgnoreCasePos( EndTag, Result) = 0) then
      begin
        Result := '';
        exit;
      end; {前方／後方タグどちらかが無い場合は''を戻す}

      Delete( Result, 1, AnsiIgnoreCasePos(StartTag, Result) - 1 + Length(StartTag));
      //前半文字を削除｜先頭タグも削除

      Result := copy( Result, 1, AnsiIgnoreCasePos(EndTag, Result) -1);
      //タグの前にある部分を取得｜後方タグも含まない
    end;

      //LinkListにmailtoが入っていたら削除
    procedure MailToLinkDelete;
    var
      i: Integer;
    begin
      for i := LinkList.Count - 1 downto 0 do
      begin
        if (AnsiIgnoreCasePos('mailto:', LinkList.Strings[i]) <> 0)
          or (LinkList[i] = '') then
          LinkList.Delete(i);
      end;
    end;

      //LinkListにmailtoが入っていなかったら削除
    procedure MailToOtherLinkDelete;
    var
      i: Integer;
    begin
      for i := LinkList.Count - 1 downto 0 do
      begin
        if (AnsiIgnoreCasePos('mailto:', LinkList.Strings[i]) = 0) then
          LinkList.Delete(i);
      end;
    end;

      //http://が入っていたら削除
    procedure HttpLinkDelete;
    var
      i: Integer;
    begin
      for i := LinkList.Count - 1 downto 0 do
      begin
        if (AnsiIgnoreCasePos('http://', LinkList.Strings[i]) <> 0)
          or (LinkList[i] = '') then
          LinkList.Delete(i);
      end;
    end;

      //http://が入っていなかったら削除
    procedure HttpOtherLinkDelete;
    var
      i: Integer;
    begin
      for i := LinkList.Count - 1 downto 0 do
      begin
        if (AnsiIgnoreCasePos('http://', LinkList.Strings[i]) = 0) then
          LinkList.Delete(i);
      end;
    end;

      //JumpLink#の指定を削除、ジャンプリンクのみのリンクなら行も削除
    procedure JumpLinkDelete;
    var
      i: Integer;
    begin
      for i := LinkList.Count - 1 downto 0 do
      begin
        //URL#top|リンクという書式であるのか
        if AnsiIgnoreCasePos('#', LinkList[i]) <> 0 then
        begin
          //#より左の部分がヌルかどうか
          if DelimiterLeft('#', LinkList[i]) = '' then
            LinkList.Delete(i)
          else
            LinkList[i] :=
              DelimiterLeft('#', LinkList[i])
              + '|' +
              DelimiterRight('|', LinkList[i]);
        end;
      end;
    end;

var
  i, LoopCount: Integer;
  Str: String;
  SList: TStringList;
begin
  Str := StringReplace(HtmlText, #13, '', [rfReplaceAll]);
  Str := StringReplace(     Str, #10, '', [rfReplaceAll]);
  //改行をすべて削除

  Str := StringReplace(Str, '</A>', '</A>'#13#10, [rfReplaceAll, rfIgnoreCase]);
  //'</A>'の後ろで改行

  Str := StringReplace(Str, '<A', #13#10'<A', [rfReplaceAll, rfIgnoreCase]);
  //'<A'の前で改行する

  SList := TStringList.Create;
  try
    SList.Text := Str;
    Str := '';
    LoopCount := SList.Count;
    for i := 0 to LoopCount - 1 do
    begin
      if AnsiIgnoreCasePos('href', SList[i]) <> 0 then
        Str := Str + SList[i] +#13#10;
    end;
  finally
    SList.Free;
  end;

  LinkList.Text := Str;

//この時点でテキストは<A HREFで始まり</A>で終わる行ばかりになっている
//※

  for i := 0 to LinkList.Count - 1 do
  begin
    LinkList.Strings[i] :=
      GetTagText(LinkList.Strings[i], '"', '"')
      +'|'+
      HtmlTagDelete( LinkList.Strings[i]);
  end;
  //タグの中身を切り出す
  //『URL』｜『リンク名』という構成になる

  //LinkListTypeによって処理分け
  case LinkListType of
    llFull:
    begin

    end;
    llExternal:
    begin
      JumpLinkDelete;
      MailToLinkDelete;
      HttpOtherLinkDelete;
    end;
    llInternal:
    begin
      JumpLinkDelete;
      MailToLinkDelete;
      HttpLinkDelete;
    end;
    llMail:
    begin
      MailToOtherLinkDelete;
    end;
  end;


{※
TagRemain(StringReplace( Memo1.Text, #13#10, '', [rfReplaceAll]),
          '<a href', '/a>', trTagCRLF);
実はこのような処理でも
<A HREF.../A>で囲まれた行だけが残る事になるので
上の※で示されているまでの処理はこの一行ですんでしまう。
たぶんTagRemainを使う方が高速だし。
まあ、好きにしてくれ
}
end;


//-------------------------------
//HTMLソースから記述されている画像ファイルを取得する
{LinkListは外部で生成しておいてください。
}
procedure MakeImgList(const HtmlText: String; LinkList: TStrings;
 ImgListType: TImgList);

      //http://が入っていたら削除
    procedure HttpLinkDelete;
    var
      i: Integer;
    begin
      for i := LinkList.Count - 1 downto 0 do
      begin
        if (AnsiIgnoreCasePos('http://', LinkList.Strings[i]) <> 0)
          or (LinkList[i] = '') then
          LinkList.Delete(i);
      end;
    end;

      //http://が入っていなかったら削除
    procedure HttpOtherLinkDelete;
    var
      i: Integer;
    begin
      for i := LinkList.Count - 1 downto 0 do
      begin
        if (AnsiIgnoreCasePos('http://', LinkList.Strings[i]) = 0) then
          LinkList.Delete(i);
      end;
    end;

    {↓テキストから'や"を基準に『'xx.gif'』を取り出す
     　Extnameは'.gif'などの形式}
    procedure GetImgFilename(Extname, Str: String;
     StringList1 :TStrings);
    var
      ExtIndex, QuotationIndex: Integer;
    begin
      ExtIndex := 1;
      while AnsiPosRange(AnsiUpperCase(Extname), AnsiUpperCase(Str),
              ExtIndex, Length(Str))<>0 do
      begin
        ExtIndex := AnsiPosRange(AnsiUpperCase(Extname),
                                    AnsiUpperCase(Str),
                                    ExtIndex, Length(Str));
        QuotationIndex := Max(
          BackAnsiPosRange('''', Str, 1, ExtIndex),
          BackAnsiPosRange('"' , Str, 1, ExtIndex));

        if QuotationIndex <> 0 then
          StringList1.Add(Copy(Str, QuotationIndex+1,
            (ExtIndex - QuotationIndex)+Length(Extname) - 1 ));

        Inc(ExtIndex);
      end;


    end;

var
  Str: String;
  SList: TStringList;
  i, LoopCount: Integer;
begin
  Str := HtmlTagRemain(HtmlText, trPerfect);
            {↑タグの中身だけを取り出し}

  SList := TStringList.Create;
  try
    GetImgFilename('.gif', Str, SList);
    GetImgFilename('.jpg', Str, SList);
    GetImgFilename('.jpeg', Str, SList);
    GetImgFilename('.png', Str, SList);
    {↑これらのファイル名だけを画像としてリスト化する}

    LinkList.Text := SList.Text;
  finally
    SList.Free;
  end;

  {↑これで『xx.gif』などファイル名だけが残る}

  LoopCount := LinkList.Count;
  for i := LoopCount - 1 downto 0 do
  begin
    if LinkList.IndexOf(LinkList.Strings[i]) <> i then
      LinkList.Delete(i);
  end; {↑ファイル名に重複項目があったら削除します}

  case ImgListType of
  {外部リンクと内部リンクかを区別します}
    ilFull :
    begin

    end;

    ilExternal:
    begin
      HttpOtherLinkDelete;
    end;

    ilInternal:
    begin
      HttpLinkDelete;
    end;
  end;
end;

////////////////////////////////////////////////////////////
//テキストから指定したタグで囲まれた部分を削除します
//タグは大小文字区別しません。
function TagDelete(const S, StartTag, EndTag: String): String;
var
  i, TagIndex, LoopCount: Integer;
  Str: String;
begin
  Str := S;
  Result := '';

  try
    {↓StartTag,EndTag,互いが互いに重複していないかをチェック}
    if ( AnsiIgnoreCasePos( EndTag, StartTag) <> 0 )
      or ( AnsiIgnoreCasePos( StartTag, EndTag) <> 0 ) then
      raise Exception.Create('タグ不正エラー');

    LoopCount := StrCount( AnsiUpperCase(StartTag), AnsiUpperCase(Str) );

    //LoopCountが0でも1〜でも対応している
    for i := 0 to LoopCount - 1 do
    begin
      TagIndex := AnsiIgnoreCasePos( StartTag, Str);
      if TagIndex = 0 then
      begin
        Str := '';
        break;
      end;
      Result := Result + copy( Str, 1, TagIndex - 1);
      Delete(Str, 1, TagIndex - 1);

      TagIndex := AnsiIgnoreCasePos( EndTag, Str);
      if TagIndex = 0 then
      begin
        Str := '';
        break;
      end;
      Delete(Str, 1, TagIndex + Length(EndTag) - 1);
    end; //for
    Result := Result + Str;

  except
    Result := '';
  end;

end;

////////////////////////////////////////////////////////////
//HTMLテキストからタグ<>で囲まれた部分を削除します
function HTMLTagDelete(const HtmlText: String): String;
begin
  Result := TagDelete( HtmlText, '<', '>');
end;

////////////////////////////////////////////////////////////
//テキストから指定したタグで囲まれた部分以外を削除します
//タグは大小文字区別しません。
{タグ自体は残ります}
function TagRemain(const S, StartTag, EndTag: String;
 TagRemainFlag: TTagRemainFlag): String;

    function CRLF(Value: Integer): String;
    var
      i: Integer;
    begin
      Result := '';
      for i := 0 to Value - 1 do
      begin
        Result := Result + #13#10;
      end;
    end;

    procedure trPerfectProc;
    begin

    end;


var
  i, TagIndex, LoopCount: Integer;
  Str: String;
begin
  Str := AdjustLineBreaks(S);
  Result := '';

  try
    if ( AnsiIgnoreCasePos( EndTag, StartTag) <> 0 )
      or ( AnsiIgnoreCasePos( StartTag, EndTag) <> 0 ) then
      raise Exception.Create('タグ不正エラー');

    LoopCount := StrCount( AnsiUpperCase(StartTag), AnsiUpperCase(Str) );

  case TagRemainFlag of
    trRemainCRLF:
    begin
//タグに囲まれていない部分を削除
//ただし改行コードは残しておく
      for i := 0 to LoopCount - 1 do
      begin
        TagIndex := AnsiIgnoreCasePos( StartTag, Str);
        //ここでtagIndexが0になることはありえない

        if copy( Str, 1, TagIndex - 1) <> '' then
          Result := Result + CRLF(StrCount( #13#10, copy( Str, 1, TagIndex - 1) ));
        Delete( Str, 1, TagIndex - 1);

        TagIndex := AnsiIgnoreCasePos( EndTag, Str);
        if TagIndex = 0 then
        begin
          Result := Result + Str;
          Str := '';
          Break;
        end;

        Result := Result + copy( Str, 1, TagIndex + Length(EndTag) - 1);
        Delete( Str, 1, TagIndex + Length(EndTag) - 1);
      end;

      DeleteExceptCRLF( Str, 1, Length(Str));
      Result := Result + Str;
    end;

    trPerfect, trTagCRLF:
    begin
//以下のコードは改行コードも含めてすべてタグに囲まれていない
//部分の文字を削除する
      for i := 0 to LoopCount - 1 do
      begin
        TagIndex := AnsiIgnoreCasePos( StartTag, Str);
        if TagIndex = 0 then
        begin
          break;
        end;
        Delete( Str, 1, TagIndex - 1);

        TagIndex := AnsiIgnoreCasePos( EndTag, Str);
        if TagIndex = 0 then
        begin
          Result := Result + Str;
          break;
        end;
        Result := Result + copy( Str, 1, TagIndex + Length(EndTag) - 1);
        Delete( Str, 1, TagIndex + Length(EndTag) - 1);
      end;
    end;
  end; //case

  case TagRemainFlag of
    trTagCRLF:
    begin
//      Result := StringReplace( Result, EndTag, EndTag+#13#10, [rfReplaceAll, rfIgnoreCase]);
//このやり方↑ではEndTagの内容が元の内容と
//大小文字が合っていないと変なので修正しました。
      Result := StringAddReplaceIgnoreAll( Result, EndTag, #13#10);
    end;
  end;

  except
    Result := '';
  end;
end;

////////////////////////////////////////////////////////////
//HTMLテキストからタグ<>で囲まれた以外の部分を削除します
function HTMLTagRemain(const HtmlText: String;
 TagRemainFlag: TTagRemainFlag): String;
begin
  Result := TagRemain( HtmlText, '<', '>', TagRemainFlag);
end;

////////////////////////////////////////////////////////////
//URLの相対アドレスから絶対アドレスを求める
function ExtractAbsoluteURL(const BaseURL, RelativeURL: string): string;
var
  i, LoopCount: Integer;
begin
  if (AnsiLowerCase( copy(RelativeURL, 1, 7) ) = 'http://')
    or (AnsiLowerCase( copy(RelativeURL, 1, 8) ) = 'file:///') then
  begin
    Result := RelativeURL;
    exit;
  end;


  if (AnsiLowerCase( copy(BaseURL, 1, 7) ) = 'http://')
    or (AnsiLowerCase( copy(BaseURL, 1, 8) ) = 'file:///') then
  begin

    Result := RemoveSlashMark( BaseURL );
    if AnsiPos('.', DelimiterRight('/', Result)) = 0 then
    //URLの最後にピリオドが含まれていないのなら
    begin
      Result := Result + '/a.a';
    end;

//この時点でhttp://xxx〜xxx/xx.xという書式は保証されたようなもの

    LoopCount := StrCount('../', RelativeURL);
    for i := 0 to LoopCount - 1 + 1 do
    begin
      Result := DelimiterLeftLong('/', Result);
    end;

//この時点でhttp://xxx〜xxxとフォルダ名になっているはず

    if RelativeURL[1] = '/' then
      Result := Result + RelativeURL
    else
      Result := Result + '/' + RelativeURL;

    Result := StringReplace(Result, '../', '', [rfReplaceAll]);
    Result := StringReplace(Result, './',  '', [rfReplaceAll]);

  end else
  begin
    raise Exception.Create('基本URLがURLとして認識できません');
    Result := '';
  end;

end;

//-------------------------------
//URLにindex.htmlをつける関数
{
 http://Delphi.com
 http://Delphi.com/
 http://Delphi.com/index.html
   → http://Delphi.com/index.html
 http://Delphi.com/Tips.html
   → そのまま
}
function AddIndexhtml(URL: String): String;
begin
  Result := URL;
  if AnsiPos('.', DelimiterRight('/', Result)) = 0 then
  {↑URLの最後にピリオドが含まれていないのなら}
  begin
    PutSlashMark(URL);
    Result := Result + 'index.html';
  end;
end;

end.