注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

BCB-DG's Blog

...

 
 
 

日志

 
 

HTTPGet  

2008-11-25 14:12:41|  分类: Delphi |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |

unit HTTPGet;

interface

uses
  Windows, Messages, SysUtils, Classes, WinInet;

const
  DEF_INI_FILE_EXT = '.ini';               

type
  TOnProgressEvent = procedure(Sender: TObject; TotalSize, Readed: Integer) of object;
  TOnDoneFileEvent = procedure(Sender: TObject; FileName: string; FileSize: Integer) of object;
  TOnDoneStringEvent = procedure(Sender: TObject; Result: string) of object;

  THTTPGetThread = class(TThread)
  private
    FTAcceptTypes,
  FTAgent,
  FTURL,
  FTFileName,
  FTStringResult,
  FTUserName,
  FTPassword,
  FTPostQuery,
    FTReferer: string;
    FTBinaryData,
    FTUseCache: Boolean;
    FTResult: Boolean;
    FTFileSize: Integer;
    FTToFile: Boolean;
    LocalFileSize: int64;
    BytesToRead, BytesReaded: DWord;
    FTProgress: TOnProgressEvent;
    procedure UpdateProgress;
  protected
    procedure Execute; override;
  public
    constructor Create(aAcceptTypes, aAgent, aURL, aFileName, aUserName,
      aPassword, aPostQuery, aReferer: string;
      aBinaryData, aUseCache: Boolean; aProgress: TOnProgressEvent; aToFile:
      Boolean);
  end;

  THTTPGet = class(TComponent)
  private
    FAcceptTypes: string;
    FAgent: string;
    FBinaryData: Boolean;
    FURL: string;
    FUseCache: Boolean;
    FFileName: string;
    FUserName: string;
    FPassword: string;
    FPostQuery: string;
    FReferer: string;
    FWaitThread: Boolean;

    FThread: THTTPGetThread;
    FError: TNotifyEvent;
    FResult: Boolean;

    FProgress: TOnProgressEvent;
    FDoneFile: TOnDoneFileEvent;
    FDoneString: TOnDoneStringEvent;

    procedure ThreadDone(Sender: TObject);
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;

    procedure GetFile;
    procedure GetString;
    procedure Abort;
  published
    property AcceptTypes: string read FAcceptTypes write FAcceptTypes;
    property Agent: string read FAgent write FAgent;
    property BinaryData: Boolean read FBinaryData write FBinaryData;
    property URL: string read FURL write FURL;
    property UseCache: Boolean read FUseCache write FUseCache;
    property FileName: string read FFileName write FFileName;
    property UserName: string read FUserName write FUserName;
    property Password: string read FPassword write FPassword;
    property PostQuery: string read FPostQuery write FPostQuery;
    property Referer: string read FReferer write FReferer;
    property WaitThread: Boolean read FWaitThread write FWaitThread;

    property OnProgress: TOnProgressEvent read FProgress write FProgress;
    property OnDoneFile: TOnDoneFileEvent read FDoneFile write FDoneFile;
    property OnDoneString: TOnDoneStringEvent read FDoneString write
      FDoneString;
    property OnError: TNotifyEvent read FError write FError;
  end;

procedure Register;

implementation

//  THTTPGetThread
constructor THTTPGetThread.Create(aAcceptTypes, aAgent, aURL, aFileName,
  aUserName, aPassword, aPostQuery, aReferer: string;
  aBinaryData, aUseCache: Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);
begin
  FreeOnTerminate := True;
  inherited Create(True);
  FTAcceptTypes := aAcceptTypes;
  FTAgent := aAgent;
  FTURL := aURL;
  FTFileName := aFileName;
  FTUserName := aUserName;
  FTPassword := aPassword;
  FTPostQuery := aPostQuery;
  FTReferer := aReferer;
  FTProgress := aProgress;
  FTBinaryData := aBinaryData;
  FTUseCache := aUseCache;
  FTToFile := aToFile;
  Resume;
end;

procedure THTTPGetThread.UpdateProgress;
begin
  FTProgress(Self, FTFileSize, BytesReaded+LocalFileSize);
end;

procedure THTTPGetThread.Execute;
var
  hSession, hConnect, hRequest: hInternet;
  HostName, FileName, HostPort: string;
  f: file;
  Buf: Pointer;
  dwBufLen, dwIndex: DWord;
  Data: array[0..$400] of Char;
  TempStr: string;
  RequestMethod: PChar;
  InternetFlag: DWord;
  AcceptType: LPStr;
  nPort: integer;
  //=====================================
  //==斷點續傳變量
  IniFile: string;
  ServerModiDate, ModiDate: string;
  UrlHeader: string;
  pDate: Pointer;
  dwDateLen, dwIndex2: DWord;
  FTResult2: Boolean;
  //=====================================

  procedure ParseURL(URL: string; var HostName, FileName, HostPort: string);
    procedure ReplaceChar(c1, c2: Char; var St: string);
    var
      p: Integer;
    begin
      while True do
      begin
        p := Pos(c1, St);
        if p = 0 then
          Break
        else
          St[p] := c2;
      end;
    end;

  var
    i: Integer;
    sPortPos, ePortPos: integer;
  begin
    if Pos('http://', LowerCase(URL)) <> 0 then System.Delete(URL, 1, 7);
    i := Pos('/', URL);
    HostName := Copy(URL, 1, i - 1);
    FileName := Copy(URL, i, Length(URL) - i + 1);
    sPortPos := Pos(':', Url);
    if sPortPos > 0 then
    begin
      ePortPos := Pos('/', Url);
      HostPort := Copy(Url, sPortPos + 1, ePortPos - sPortPos - 1);
      HostName := Copy(HostName, 0, Pos(':', HostName) - 1);
    end;
    if (Length(HostName) > 0) and (HostName[Length(HostName)] = '/') then SetLength(HostName, Length(HostName) - 1);
  end;

  procedure CloseHandles;
  begin
    InternetCloseHandle(hRequest);
    InternetCloseHandle(hConnect);
    InternetCloseHandle(hSession);
  end;

  function GetFileModiDate(FileName: string): string;
  var
    Fs: TStringList;
  begin
    Result := '';
    Fs := TStringList.Create;
    try
      Fs.LoadFromFile(FileName);
      if Fs.Count > 0 then
        Result := Fs.Strings[0];
    finally
      Fs.Free;
    end;
  end;

  function GetFileSize(FileName: string): int64;
  var
    FStream: TFileStream;
  begin
    Result := 0;
    try
      FStream := TFileStream.Create(FileName, fmShareDenyNone);
      Result := FStream.Size;
    finally
      FStream.Free;
    end;
  end;

  procedure SaveToFile1(Scr: string; FileName: string);
  var
    fs: TStringList;
  begin
    try
      if FileExists(FileName) then DeleteFile(FileName);
    except
      Exit;
    end;
    fs := TStringList.Create;
    fs.Add(scr);
    fs.SaveToFile(FileName);
    fs.Free;
  end;

begin
  //檢查本地是否有下載到一半的文件及說明文件
  LocalFileSize := 0;
  IniFile := FTFileName + DEF_INI_FILE_EXT;
  if FileExists(FTFileName) then
  begin
    if FileExists(IniFile) then //取出當時下載的文件在修改日期,用于和服務器比較是否還是同一文件
    begin
      ModiDate := GetFileModiDate(IniFile);
      if ModiDate <> '' then
      begin
        LocalFileSize := GetFileSize(FTFileName); //得到本地已下載的大小
      end;
    end;
  end;
 
 try
    HostPort := '80';
    ParseURL(FTURL, HostName, FileName, HostPort);
    try
      nPort := StrToInt(HostPort);
    except
      nPort := 80;
    end;

    if Terminated then
    begin
      FTResult := False;
      Exit;
    end;

    if FTAgent <> '' then
      hSession := InternetOpen(PChar(FTAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0)
    else
      hSession := InternetOpen(nil, INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
    hConnect := InternetConnect(hSession, PChar(HostName), nPort, PChar(FTUserName), PChar(FTPassword), INTERNET_SERVICE_HTTP, 0, 0);

    if FTPostQuery = '' then
      RequestMethod := 'GET'
    else
      RequestMethod := 'POST';

    if FTUseCache then
      InternetFlag := 0
    else
      InternetFlag := INTERNET_FLAG_RELOAD;

    AcceptType := PChar('Accept: ' + FTAcceptTypes);
    hRequest := HttpOpenRequest(hConnect, RequestMethod, PChar(FileName), 'HTTP/1.1', PChar(FTReferer), @AcceptType, InternetFlag, 0);

    if FTPostQuery = '' then
      HttpSendRequest(hRequest, nil, 0, nil, 0)
    else
      HttpSendRequest(hRequest, 'Content-Type: application/x-www-form-urlencoded', 47, PChar(FTPostQuery), Length(FTPostQuery));
    if Terminated then
    begin
      CloseHandles;
      FTResult := False;
      Exit;
    end;

    dwIndex := 0;
    dwBufLen := 2048;
    GetMem(Buf, dwBufLen);
    FTResult := HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH, Buf, dwBufLen, dwIndex);
    if FTResult or not FTBinaryData then
    begin
      if FTResult then FTFileSize := StrToInt(StrPas(Buf));
    end;
   
  dwIndex2 := 0;
    dwDateLen := 256;
    GetMem(pDate, dwDateLen);
    FTResult2 := HttpQueryInfo(hRequest, HTTP_QUERY_LAST_MODIFIED, pDate, dwDateLen, dwIndex2);
    if FTresult2 then
    begin
      ServerModiDate := StrPas(pDate);
      if ServerModiDate <> '' then SaveToFile1(ServerModiDate, IniFile);
    end;
  
    if Terminated then
    begin
      FreeMem(Buf);
      FreeMem(pDate);
      CloseHandles;
      FTResult := False;
      Exit;
    end;

     //首先判斷服務器支持不支持斷點續傳,不支持,則刪除本地文件,重新下載.
     //支持,則生成新的請求頭字符串,send到服務器上
    BytesReaded := 0;
    if FTToFile then
    begin
      AssignFile(f, FTFileName);
      if ServerModiDate = ModiDate then
      begin
        reset(f, 1);
        seek(f, localFileSize);
      end
      else
      begin
        Rewrite(f, 1);
      end;
    end
    else
      FTStringResult := '';

    if ServerModiDate = ModiDate then
    begin
      InternetCloseHandle(hRequest);
      hRequest := HttpOpenRequest(hConnect, RequestMethod, PChar(FileName), 'HTTP/1.1', PChar(FTReferer), @AcceptType, InternetFlag, 0);
      if FTPostQuery = '' then
      begin
        UrlHeader := 'RANGE: bytes=' + IntToStr(LocalFileSize) + '-' +
          IntToStr(FTFileSize)
          + #13#10;
        HttpSendRequest(hRequest, pchar(UrlHeader), Length(UrlHeader), nil, 0);
      end
      else
      begin
        UrlHeader := 'Content-Type: application/x-www-form-urlencoded' + #13#10
          +
          'RANGE: bytes=' + IntToStr(LocalFileSize) + '-' + IntToStr(FTFileSize)
          + #13#10;
        HttpSendRequest(hRequest, pchar(UrlHeader), Length(UrlHeader), PChar(FTPostQuery), Length(FTPostQuery));
      end;
    end;

    while True do
    begin
      if Terminated then
      begin
        if FTToFile then CloseFile(f);
        FreeMem(Buf);
        FreeMem(pDate);
        CloseHandles;
        FTResult := False;
        Exit;
      end;

      if not InternetReadFile(hRequest, @Data, SizeOf(Data), BytesToRead) then
        Break
      else if BytesToRead = 0 then
        Break
      else
      begin
        if FTToFile then
          BlockWrite(f, Data, BytesToRead)
        else
        begin
          TempStr := Data;
          SetLength(TempStr, BytesToRead);
          FTStringResult := FTStringResult + TempStr;
        end;

        inc(BytesReaded, BytesToRead);
        if Assigned(FTProgress) then Synchronize(UpdateProgress);
      end;
    end;

    if FTToFile then
      FTResult := (FTFileSize - LocalFileSize) = Integer(BytesReaded)
    else
    begin
      SetLength(FTStringResult, BytesReaded);
      FTResult := BytesReaded <> 0;
    end;

    if FTToFile then CloseFile(f);

    FreeMem(Buf);
    FreeMem(pDate);
    CloseHandles;
  except
  end;
end;

// HTTPGet
constructor THTTPGet.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  FAcceptTypes := '*/*';
  FAgent := 'UtilMind HTTPGet';
end;

destructor THTTPGet.Destroy;
begin
  Abort;
  inherited Destroy;
end;

procedure THTTPGet.GetFile;
var
  Msg: TMsg;
begin
  if not Assigned(FThread) then
  begin
    FThread := THTTPGetThread.Create(FAcceptTypes, FAgent, FURL, FFileName,
      FUserName, FPassword, FPostQuery, FReferer,
      FBinaryData, FUseCache, FProgress, True);
    FThread.OnTerminate := ThreadDone;
    if FWaitThread then
      while Assigned(FThread) do
        while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
        begin
          TranslateMessage(Msg);
          DispatchMessage(Msg);
        end;
  end
end;

procedure THTTPGet.GetString;
var
  Msg: TMsg;
begin
  if not Assigned(FThread) then
  begin
    FThread := THTTPGetThread.Create(FAcceptTypes, FAgent, FURL, FFileName,
      FUserName, FPassword, FPostQuery, FReferer,
      FBinaryData, FUseCache, FProgress, False);
    FThread.OnTerminate := ThreadDone;
    if FWaitThread then
      while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
      begin
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end;
  end
end;

procedure THTTPGet.Abort;
begin
  if Assigned(FThread) then
  begin
    FThread.Terminate;
    FThread.FTResult := False;
  end;
end;

procedure THTTPGet.ThreadDone(Sender: TObject);
begin
  FResult := FThread.FTResult;
  if FResult then
    if FThread.FTToFile then
      if Assigned(FDoneFile) then
        FDoneFile(Self, FThread.FTFileName, FThread.FTFileSize)
      else
    else if Assigned(FDoneString) then
      FDoneString(Self, FThread.FTStringResult)
    else
  else if Assigned(FError) then
    FError(Self);
  FThread := nil;
end;

procedure Register;
begin
  RegisterComponents('UtilMind', [THTTPGet]);
end;

end.

  评论这张
 
阅读(1420)| 评论(0)
推荐 转载

历史上的今天

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2017