myhttptask.pas

ThreadPro 是本人开发的一套用于多线程编程的 Delphi 基础类库

unit MyHTTPtask;

interface

uses
  HTTPtask, ThreadTask, SysUtils, DateUtils, Classes,
  Define; //在TWebSearch的设计中用到了些许定义，所以在这里加上该单元

type
  {used in demo1}
  TThreadTaskDemo = class(TAdvThreadTask)   //普通任务线程类从  TAdvThreadTask 继承即可
  protected
    procedure Dojob; override;  // 只需且必须覆盖父类的这个方法
  public
    _PARAM : Integer; // 延时
  end;

  {用于验证代理的HTTP线程类 used in demo2}
  TCheckProxy = class(THTTPtask)  // 从 THTTPtask 继承
  protected
    procedure Process; override;  // 只需要覆盖父类的这个方法即可
  public
    _TARGET_URL : string;
    _SUCC_STR : string;
  end;

  {ok 下面我们来封装一个较为复杂的HTTP线程类 used in demo3 （稍加修改你就可以作出一个丝毫不比"中华搜索宝"逊色的搜索软件了^_^）}
  //首先定义一个事件
  TSrhRetFindEvent = procedure(Link,LinkText : string; PageNo : Integer; Engine : Byte; Sender : TObject) of object;
  //接着来设计一个用于搜索的基类
  TWebSearch = class(THTTPtask)
  private
    _LINK : string;
    _LINK_TEXT : string;
  protected
    _CURR_PAGE : Integer;
    _ENGINE : Byte;
    _LANGUAGE : Byte;
    _UTF8 : Boolean;
    procedure Process; override;
    function SetSearchUrl : string; virtual; abstract;
    function AnalyzeLink(inUrl : string; var outUrl :string):boolean; virtual; abstract;
    procedure AnalyzePage;
    procedure SrhRetFind(Link : string);
    procedure SynSrhRetFind;
  public
    _KEYWORD : string;
    _PAGE_COUNT : Integer;
    _OnSrhRetFind : TSrhRetFindEvent;
  end;

  //下面的顾名思义吧
  TGoogleSearch = class(TWebSearch)
  protected
    function SetSearchUrl : string; override;
    function AnalyzeLink(inUrl : string; var outUrl :string):boolean; override;
  end;

  TBaiduSearch = class(TWebSearch)
  protected
    function SetSearchUrl : string; override;
    function AnalyzeLink(inUrl : string; var outUrl :string):boolean; override;
  end;

  TYahooSearch = class(TWebSearch)
  protected
    function SetSearchUrl : string; override;
    function AnalyzeLink(inUrl : string; var outUrl :string):boolean; override;
  end;

  TSinaSearch = class(TWebSearch)
  protected
    function SetSearchUrl : string; override;
    function AnalyzeLink(inUrl : string; var outUrl :string):boolean; override;
  end;

  TSogouSearch = class(TWebSearch)
  protected
    function SetSearchUrl : string; override;
    function AnalyzeLink(inUrl : string; var outUrl :string):boolean; override;
  end;

  TChinaSearch = class(TWebSearch)
  protected
    function SetSearchUrl : string; override;
    function AnalyzeLink(inUrl : string; var outUrl :string):boolean; override;
  end;
  { 不如你自己来完成下面MSN引擎的封装吧^_^ 或者你可以写出更多的TWebSearch子类，只需要覆盖这两个方法就可以了
  TMsnSearch = class(TWebSearch)
  protected
    function SetSearchUrl : string; override;
    function AnalyzeLink(inUrl : string; var outUrl :string):boolean; override;
  end;
  }

implementation

uses
  HTTPutil;

procedure TThreadTaskDemo.Dojob;
  procedure TracePro(s : string);
  begin
    TraceLog(Format('THREAD%sTASK%sLOG%s',[FormatStrNum(_THREAD_INDEX,3),FormatStrNum(_TASK_INDEX,3),s]));
  end;
begin
  LvTraceLog('正在初始化',_TASK_INDEX,2,3);
  TracePro('正在初始化');
  Sleep(Random(1000)+1000);                                   //此处仅随机延时，用于演示
  LvTraceLog('正在载入数据',_TASK_INDEX,2,-1);
  TracePro('正在载入数据');
  Sleep(_PARAM);
  LvTraceLog(Format('线程终止,延时 %d 毫秒',[_PARAM]),_TASK_INDEX,2,-1);
  TracePro(IntToStr(_PARAM));
  Sleep(Random(1000)+1000);
  //你可以设置_SUCCCESS 标志位来表示该线程运行的结果成功与否，当线程池以“瞬死--SuddenDeath”模式运行时，
  //一旦有一个线程运行结果为成功线程池将自动终止，不再运行余下的任务，
  //该模式一般用于穷举破解。
  //这里我们随机的设置瞬死点，瞬死概率为5％
  _SUCCCESS := Random(20)=1;
  LvTraceLog(BoolToStr(_SUCCCESS),_TASK_INDEX,3,BoolToInt(_SUCCCESS)+1);
end;

{TCheckProxy}
procedure TCheckProxy.Process;
var
  Tick : TDateTime;
begin
  Tick := 0;
  LvTraceLog('正在验证...',_TASK_INDEX,3,3);
  try
    Tick := now;
    GetHtml(_TARGET_URL);     //使用该方法来访问URL，此方法支持GZIP加速，如要POST数据，则使用PostHtml方法，文件图片等可以使用 GetStream 方法
//    DebugHtml;
    if Pos(_SUCC_STR,_HTML)>0 then
    _SUCCCESS := True;
  except
  end;
  LvTraceLog('验证'+BoolToStr(_SUCCCESS),_TASK_INDEX,3,BoolToInt(_SUCCCESS)+1); //显示验证结果
  if _SUCCCESS then
  LvTraceLog(Format('%d ms',[MilliSecondsBetween(Now,Tick)]),_TASK_INDEX,4,-1);   //显示速度
end;

{TWebSearch}
procedure TWebSearch.Process;
var
  i : Integer;
begin
  for i:=0 to _PAGE_COUNT-1 do
  begin
   if Terminated then break;
   _CURR_PAGE := i;
   PauseHere;
   try
     GetHtml(SetSearchUrl);
//     DebugHtml;
   except
     on e: Exception do
     begin
       TraceLog(Format('读取第 %d 页时发生错误:%s',[I,E.Message]));
       Continue;
     end;
   end;
   AnalyzePage;
  end;
end;

procedure TWebSearch.AnalyzePage;
var
  Links : TStringList;
  LinksFound,i : Integer;
  outUrl : string;
begin
  Links := TStringList.Create;
  LinksFound := ExtractHtmlTagValues(_HTML, 'A', 'HREF', Links);
  try
    for i:=0 to LinksFound-1 do
    begin
      if AnalyzeLink(LowerCase(Links[i]),outUrl) then
        SrhRetFind(outUrl);
    end;
  finally
    Links.Free;
  end;
end;

procedure TWebSearch.SynSrhRetFind;
begin
  if Assigned(_OnSrhRetFind) then
  _OnSrhRetFind(_LINK,_LINK_TEXT,_CURR_PAGE,_ENGINE, Self);
end;

procedure TWebSearch.SrhRetFind(Link : string);
begin
  _LINK := Link;
  _LINK_TEXT := GetLinkTextByUniqueURL(_HTML,_LINK);
  if _UTF8 then
  _LINK_TEXT := Utf8ToAnsi(_LINK_TEXT);
  RmHtmlTags(_LINK_TEXT);
  Synchronize(SynSrhRetFind);
end;


{TGoogleSearch}
function TGoogleSearch.SetSearchUrl :string;
const
  GG_PRE = 'http://www.google.com/search?q=';
  GG_NUM = '&num=';
  GG_MID = '&hl=zh-CN&lr=&newwindow=1&start=';
  GG_END = '&sa=N';
  GG_PN  = 100;
begin
  Result := GG_PRE + URLEncode(_KEYWORD) + GG_NUM + IntToStr(GG_PN) + GG_MID + IntToStr(_CURR_PAGE*GG_PN) + GG_END;
  //
  _ENGINE := Integer(weGoogle);
  _UTF8 := True;
end;

function TGoogleSearch.AnalyzeLink(inUrl : string; var outUrl :string):boolean;
const
  GG_CRT = 'q=related:';
var
  iPos : Integer;
begin
  iPos := Pos(GG_CRT,inUrl);
  Result := iPos > 0 ;
  if Result then
  begin
    outUrl := inUrl;
    Delete(outUrl,1,Length(GG_CRT)+iPos-1);
    outUrl := 'http://'+outUrl;
  end;
end;

{TBaiduSearch}
function TBaiduSearch.SetSearchUrl :string;
const
  BD_PRE = 'http://www.baidu.com/s?lm=0&si=&rn=';
  BD_MIDH = '&ie=gb2312&ct=0&wd=';
  BD_MIDL = '&pn=';
  BD_END = '&cl=3';
  BD_PN  = 100;
begin
  Result := BD_PRE + IntToStr(BD_PN) + BD_MIDH + URLEncode(_KEYWORD) + BD_MIDL + IntToStr(_CURR_PAGE*BD_PN) + BD_END;
  //
  _ENGINE := Integer(weBaidu);
  _UTF8 := False;
end;

function TBaiduSearch.AnalyzeLink(inUrl : string; var outUrl :string):boolean;
const
  BD_CRTL = '&url=';
  BD_TAL = '&b=';
  BD_COM = 'http://www.baidu.com/baidu.php?url=';
var
  iPos : Integer;
begin
  iPos := Pos(BD_CRTL,inUrl);
  Result := iPos > 0 ;
  if Result then
  begin
    outUrl := inUrl;
    Delete(outUrl,1,Length(BD_CRTL)+iPos-1);
    iPos := Pos(BD_TAL,outUrl);
    if iPos>0 then outUrl := Copy(outUrl,1,iPos-1);
    outUrl := UrlDecode(outUrl);
    Exit;
  end;
  iPos := Pos(BD_COM,inUrl);
  Result := iPos > 0 ;
  if Result then
    outUrl := inUrl;
end;

{TYahooSearch}
function TYahooSearch.SetSearchUrl :string;
const
  YH_PRE = 'http://search.cn.yahoo.com/search?p=';
  YH_MID = '&pid=ysearch&ei=UTF-8&b=';
begin
  Result := YH_PRE + URLEncode(AnsiToUtf8(_KEYWORD)) + YH_MID + IntToStr(_CURR_PAGE*10+1);
  //
  _ENGINE := Integer(weYahoo);
  _UTF8 := True;
end;

function TYahooSearch.AnalyzeLink(inUrl : string; var outUrl :string):boolean;
const
  YH_CRT = 'cache.html?ei=UTF-8&icp=1&u=';
  YH_W   = '&w=';
var
  iPos : Integer;
begin
  iPos := Pos(LowerCase(YH_CRT),inUrl);
  Result := iPos > 0 ;
  if Result then
  begin
    outUrl := inUrl;
    Delete(outUrl,1,Length(YH_CRT)+iPos-1);
    iPos := Pos(YH_W,outUrl);
    if iPos>0 then
    outUrl := Copy(outUrl,1,iPos-1) ;
    outUrl := 'http://'+outUrl;
  end;
end;

{TSinaSearch}
function TSinaSearch.SetSearchUrl :string;
const
  SN_PRE = 'http://iask.com/s?k=';
  SN_MID = '&p=';
begin
  Result := SN_PRE + URLEncode(_KEYWORD) + SN_MID + IntToStr(_CURR_PAGE+1);
  //
  _ENGINE := Integer(weSina);
  _UTF8 := False;
end;

function TSinaSearch.AnalyzeLink(inUrl : string; var outUrl :string):boolean;
const
  SN_SINA = 'sina.com';
  SN_IASK = 'iask.com';
  SN_JAVA = 'javascript';
begin
  Result := (Pos(SN_SINA,inUrl) + Pos(SN_IASK,inUrl) + Pos(SN_JAVA,inUrl) = 0) and
            (Pos('/',inUrl)<>1);
  if Result then
    outUrl := inUrl;
end;

{TSogouSearch}
function TSogouSearch.SetSearchUrl :string;
const
  SG_PRE = 'http://www.sogou.com/web?&query=';
  SG_PGN = '&page=';
  SG_NUM = '&num=';
  SG_SPN  = '100';
begin
  Result := SG_PRE + URLEncode(_KEYWORD) + SG_PGN + IntToStr(_CURR_PAGE+1) + SG_NUM + SG_SPN;
  //
  _ENGINE := Integer(weSogou);
  _UTF8 := False;
end;

function TSogouSearch.AnalyzeLink(inUrl : string; var outUrl :string):boolean;
const
  SG_CRT = 'websnapshot.do?url=';
  SG_QRY = '&query=';
var
  iPos : Integer;
begin
  iPos := Pos(LowerCase(SG_CRT),inUrl);
  Result := iPos > 0 ;
  if Result then
  begin
    outUrl := inUrl;
    Delete(outUrl,1,Length(SG_CRT)+iPos-1);
    iPos := Pos(SG_QRY,outUrl);
    if iPos>0 then
    outUrl := UrlDecode( Copy(outUrl,1,iPos-1) );
  end;
end;

{TChinaSearch}
function TChinaSearch.SetSearchUrl :string;
const
  ZS_PRE = 'http://p.zhongsou.com/p?w=';
  ZS_PGN = '&b=';
begin
  Result := ZS_PRE + URLEncode(_KEYWORD) + ZS_PGN + IntToStr(_CURR_PAGE+1);
  //
  _ENGINE := Integer(weZhongSou);
  _UTF8 := False;
end;

function TChinaSearch.AnalyzeLink(inUrl : string; var outUrl :string):boolean;
const
  ZS_CRT = '&u1=';
var
  iPos : Integer;
begin
  iPos := Pos(LowerCase(ZS_CRT),inUrl);
  Result := iPos > 0 ;
  if Result then
  begin
    outUrl := inUrl;
    Delete(outUrl,1,Length(ZS_CRT)+iPos-1);
  end;
end;

end.