httpget.pas

实现自制的程序的自动升级

{*************************************************************}
{            HTTPGet component for Delphi 32                  }
{ Version:   1.94                                             }
{ E-Mail:    [e-mail]                                }
{ WWW:       http://www.utilmind.com                          }
{ Created:   October  19, 1999                                }
{ Modified:  June 6, 2000                                     }
{ Legal:     Copyright (c) 1999-2000, UtilMind Solutions      }
{*************************************************************}
{ PROPERTIES:                                                 }
{   Agent: String - User Agent                                }
{                                                             }
{*  BinaryData: Boolean - This setting specifies which type   }
{*                        of data will taken from the web.    }
{*                        If you set this property TRUE then  }
{*                        component will determinee the size  }
{*                        of files *before* getting them from }
{*                        the web.                            }
{*                        If this property is FALSE then as we}
{*                        do not knows the file size the      }
{*                        OnProgress event will doesn't work. }
{*                        Also please remember that is you set}
{*                        this property as TRUE you will not  }
{*                        capable to get from the web ASCII   }
{*                        data and ofter got OnError event.   }
{                                                             }
{   FileName: String - Path to local file to store the data   }
{                      taken from the web                     }
{   Password, UserName - set this properties if you trying to }
{                        get data from password protected     }
{                        directories.                         }
{   Referer: String - Additional data about referer document  }
{   URL: String - The url to file or document                 }
{   UseCache: Boolean - Get file from the Internet Explorer's }
{                       cache if requested file is cached.    }
{*************************************************************}
{ METHODS:                                                    }
{   GetFile - Get the file from the web specified in the URL  }
{             property and store it to the file specified in  }
{             the FileName property                           }
{   GetString - Get the data from web and return it as usual  }
{               String. You can receive this string hooking   }
{               the OnDoneString event.                       }
{   Abort - Stop the current session                          }
{*************************************************************}
{ EVENTS:                                                     }
{   OnDoneFile - Occurs when the file is downloaded           }
{   OnDoneString - Occurs when the string is received         }
{   OnError - Occurs when error happend                       }
{   OnProgress - Occurs at the receiving of the BINARY DATA   }
{*************************************************************}
{ Please see demo program for more information.               }
{*************************************************************}
{                     IMPORTANT NOTE:                         }
{ This software is provided 'as-is', without any express or   }
{ implied warranty. In no event will the author be held       }
{ liable for any damages arising from the use of this         }
{ software.                                                   }
{ Permission is granted to anyone to use this software for    }
{ any purpose, including commercial applications, and to      }
{ alter it and redistribute it freely, subject to the         }
{ following restrictions:                                     }
{ 1. The origin of this software must not be misrepresented,  }
{    you must not claim that you wrote the original software. }
{    If you use this software in a product, an acknowledgment }
{    in the product documentation would be appreciated but is }
{    not required.                                            }
{ 2. Altered source versions must be plainly marked as such,  }
{    and must not be misrepresented as being the original     }
{    software.                                                }
{ 3. This notice may not be removed or altered from any       }
{    source distribution.                                     }
{*************************************************************}

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;