updatefrm.pas

UPXShell 压缩解压缩Windows下的exe和dll文件, 其原理基于加壳原理, UPX也是一个Windows下的可执行文件加壳工具

Unit UpdateFrm;
Interface
Uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ShellApi, WinInet, Translator, Globals, Shared;
Type
  TUpdateForm = Class(TForm)
    grpProgress: TGroupBox;
    lblStatus: TLabel;
    grpUpdateInfo: TGroupBox;
    lblReleaseCap: TLabel;
    lblBuildCap: TLabel;
    lblRelease: TLabel;
    lblBuild: TLabel;
    lblDateCap: TLabel;
    lblDate: TLabel;
    lblSizeCap: TLabel;
    lblSize: TLabel;
    btnOk: TButton;
    memNews: TMemo;
    lblNews: TLabel;
    grpDownload: TGroupBox;
    lblDownload: TLabel;
    Procedure FormCreate(Sender: TObject);
    Procedure FormClose(Sender: TObject; Var Action: TCloseAction);
    Procedure FormActivate(Sender: TObject);
    Procedure DownloadClick(Sender: TObject);
  Private
    FUpdateUrl: String; //Holds update file url (.txt)
    FLocalName: String; //Local name to save update file
    FUpdateDownload: String; //Holds program update file url (.exe)
    Procedure CheckForUpdate;
    Procedure Error(Sender: TObject);
    Procedure UpdateDone(Sender: TObject; FileName: String; FileSize: Integer);
  Public
    Constructor Create(AOwner: TComponent; Url, LocalName: String); Reintroduce;
  End;
Const
  UpdateHeader = '<ION Tek update file>';
Var
  UpdateForm: TUpdateForm;
Implementation
{$R *.dfm}
{ The following stuff is a rip from HTTPGET component by UtilMind.
  I don't claim it to be my own, though it's not official release
  stuff neither:) It's just an adoption of HTTPGET to my needs,
  which is permitted by author:)) Also I don't add the rip from GNU
  Public License as it's of no use:), though HTTPGET author asked
  to do so=)
}
Type
  TOnProgressEvent = Procedure(Sender: TObject; TotalSize, Received: 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;
    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;
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);
End;
Procedure THTTPGetThread.Execute;
Var
  hSession, hConnect, hRequest: hInternet;
  HostName, FileName: String;
  f: File;
  Buf: Pointer;
  dwBufLen, dwIndex: DWord;
  Data: Array[0..$400] Of Char;
  TempStr: String;
  RequestMethod: PChar;
  InternetFlag: DWord;
  AcceptType: LPStr;
  Procedure ParseURL(URL: String; Var HostName, FileName: 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;
  Begin
    If Pos('http://', LowerCase(URL)) <> 0 Then
      System.Delete(URL, 1, 7);
    i := Pos('/', URL);
    HostName := Copy(URL, 1, i);
    FileName := Copy(URL, i, Length(URL) - i + 1);
    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;
Begin
  Try
    ParseURL(FTURL, HostName, FileName);
    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),
      INTERNET_DEFAULT_HTTP_PORT, 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.0',
      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 := 1024;
    GetMem(Buf, dwBufLen);
    FTResult := HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH,
      Buf, dwBufLen, dwIndex);
    If Terminated Then
    Begin
      FreeMem(Buf);
      CloseHandles;
      FTResult := False;
      Exit;
    End;
    If FTResult Or Not FTBinaryData Then
    Begin
      If FTResult Then
        FTFileSize := StrToInt(StrPas(Buf));
      BytesReaded := 0;
      If FTToFile Then
      Begin
        AssignFile(f, FTFileName);
        Rewrite(f, 1);
      End
      Else
        FTStringResult := '';
      While True Do
      Begin
        If Terminated Then
        Begin
          If FTToFile Then CloseFile(f);
          FreeMem(Buf);
          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 = Integer(BytesReaded)
      Else
      Begin
        SetLength(FTStringResult, BytesReaded);
        FTResult := BytesReaded <> 0;
      End;
      If FTToFile Then CloseFile(f);
    End;
    FreeMem(Buf);
    CloseHandles;