updatefrm.pas

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

  Except
  End;
End;
// HTTPGet
Constructor THTTPGet.Create(aOwner: TComponent);
Begin
  Inherited Create(aOwner);
  FAcceptTypes := '*/*';
  FAgent := 'UPX Shell 3.x update service';
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 Assigned(FThread) Do
        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;
{ The end of HTTPGET stuff }
{========================================================================}
Var
  HttpGet: THttpGet;
Constructor TUpdateForm.Create(AOwner: TComponent; Url, LocalName: String);
Begin
  Inherited Create(AOwner);
  FUpdateUrl := Url;
  FLocalName := LocalName;
End;
Procedure TUpdateForm.Error(Sender: TObject);
Begin
  UpdateForm.lblStatus.Caption := TranslateMsg('...update failed :-(');
  beep;
  Application.MessageBox(TranslateMsg('Could not connect to update server!'),
    TranslateMsg('Error'), MB_OK + MB_ICONERROR);
End;
Procedure ParseFile(FileName: String);
Var
  News: Boolean;
  Procedure RemoveTags(Var Str: String);
  Var
    posit: Integer;
  Begin
    posit := pos('<', Str);
    If posit <> 0 Then
    Begin
      Delete(Str, 1, posit);
      posit := pos('>', Str);
      If posit <> 0 Then Delete(Str, posit, length(str));
    End;
  End;
  Procedure ParseLine(Str: String);
  Begin
    If pos('Name', Str) <> 0 Then
    Begin
      Delete(str, 1, 4);
      UpdateForm.grpUpdateInfo.Caption := UpdateForm.grpUpdateInfo.Caption + Str;
    End
    Else
      If pos('Release', Str) <> 0 Then
      Begin
        Delete(str, 1, 8);
        UpdateForm.lblRelease.Caption := Str;
      End
      Else
        If pos('Build', Str) <> 0 Then
        Begin
          Delete(str, 1, 6);
          UpdateForm.lblBuild.Caption := Str;
        End
        Else
          If pos('Date', Str) <> 0 Then
          Begin
            Delete(str, 1, 5);
            UpdateForm.lblDate.Caption := Str;
          End
          Else
            If pos('Size', Str) <> 0 Then
            Begin
              Delete(str, 1, 5);
              UpdateForm.lblSize.Caption := Str;
            End
            Else
              If str = 'News' Then
              Begin
                News := True;
                UpdateForm.memNews.Clear;
              End
              Else
                If News Then
                Begin
                  If Not (str = '/News') Then
                    UpdateForm.memNews.Lines.Add(Str)
                  Else
                    News := False;
                End
                Else
                  If pos('Download', Str) <> 0 Then
                  Begin
                    Delete(str, 1, 9);
                    UpdateForm.FUpdateDownload := str;
                    UpdateForm.lblDownload.Caption := Str;
                    UpdateForm.lblDownload.Cursor := crHandPoint;
                  End;
  End;
  Procedure CheckIfNew;
  Var
    Release, Major, Minor, Build: Integer;
    NRelease, NMajor, NMinor, NBuild: Integer;
    posit: Integer;
    temp: String;
  Begin
    Temp := UpdateForm.lblRelease.Caption;
    posit := pos('.', temp);
    NRelease := StrToInt(copy(temp, 1, posit - 1));
    Delete(temp, 1, posit);
    posit := pos('.', temp);
    NMajor := StrToInt(copy(temp, 1, posit - 1));
    Delete(temp, 1, posit);
    NMinor := StrToInt(temp);
    NBuild := StrToInt(UpdateForm.lblBuild.Caption);
    Temp := GetBuild(biFull);
    ;
    posit := pos('.', temp);
    Release := StrToInt(copy(temp, 1, posit - 1));
    Delete(temp, 1, posit);
    posit := pos('.', temp);
    Major := StrToInt(copy(temp, 1, posit - 1));
    Delete(temp, 1, posit);
    posit := pos('.', temp);
    Minor := StrToInt(copy(temp, 1, posit - 1));
    Delete(temp, 1, posit);
    Build := StrToInt(temp);
    If (NBuild > Build) Or (NMinor > Minor) Or
      (NMajor > Major) Or (NRelease > Release) Then
    Begin
      UpdateForm.lblDownload.Cursor := crHandPoint;
      UpdateForm.lblDownload.OnClick := UpdateForm.DownloadClick;
      UpdateForm.lblStatus.Caption := TranslateMsg('...update found');
      Application.MessageBox(TranslateMsg('Updated version of product found!'),
        TranslateMsg('Confirmation'), MB_OK + MB_ICONEXCLAMATION);
    End
    Else
      UpdateForm.lblStatus.Caption := TranslateMsg('...no updates found');
  End;
Var
  f: textfile;
  temp: String;
Begin
  News := False;
  AssignFile(f, FileName);
  reset(f);
  ReadLn(f, temp);
  If temp = UpdateHeader Then
  Begin
    While Not EOF(f) Do
    Begin
      ReadLn(f, temp);
      RemoveTags(temp);
      ParseLine(temp);
    End;
  End
  Else
  Begin
    UpdateForm.lblStatus.Caption := TranslateMsg('...update failed :-(');
    beep;
    Application.MessageBox(TranslateMsg('Could not connect to update server!'),
      TranslateMsg('Error'), MB_OK + MB_ICONERROR);
  End;
  CloseFile(f);
  CheckIfNew;
End;
Procedure TUpdateForm.UpdateDone(Sender: TObject; FileName: String; FileSize: Integer);
Begin
  If FileSize = 0 Then
  Begin
    UpdateForm.lblStatus.Caption := TranslateMsg('...update failed :-(');
    beep;
    Application.MessageBox(TranslateMsg('Could not connect to update server!'),
      TranslateMsg('Error'), MB_OK + MB_ICONERROR);
  End
  Else
  Begin
    lblStatus.Caption := TranslateMsg('Parsing update file...');
    ParseFile(FLocalName);
  End;
  btnOk.Enabled := True;
End;
Procedure TUpdateForm.CheckForUpdate;
Begin
  lblStatus.Caption := TranslateMsg('Retrieving update information...');
  HttpGet := THttpGet.Create(UpdateForm);
  HttpGet.URL := FUpdateUrl;
  HttpGet.FileName := FLocalName;
  HttpGet.OnError := Error;
  HttpGet.OnDoneFile := UpdateDone;
  HttpGet.GetFile;
End;
Procedure TUpdateForm.FormCreate(Sender: TObject);
Var
  Save: LongInt;
Begin
  //The following code removes the form caption bar
  If BorderStyle = bsNone Then Exit;
  Save := GetWindowLong(Handle, GWL_STYLE);
  If (Save And WS_CAPTION) = WS_CAPTION Then
  Begin
    Case BorderStyle Of
      bsSingle, bsSizeable: SetWindowLong(Handle, GWL_STYLE,
          Save And (Not WS_CAPTION) Or WS_BORDER);
      bsDialog: SetWindowLong(Handle, GWL_STYLE,
          Save And (Not WS_CAPTION) Or DS_MODALFRAME Or WS_DLGFRAME);
    End;
    Height := Height - GetSystemMetrics(SM_CYCAPTION);
    Refresh;
  End;
  Application.ProcessMessages;
  memNews.Clear;
  memNews.Lines.Add(TranslateMsg('N/A'));
  CheckForUpdate;
End;
Procedure TUpdateForm.FormClose(Sender: TObject; Var Action: TCloseAction);
Begin
  HttpGet.Free;
  DeleteFile(FLocalName);
End;
Procedure TUpdateForm.FormActivate(Sender: TObject);
Begin
  TranslateForm(UpdateForm);
End;
Procedure TUpdateForm.DownloadClick(Sender: TObject);
Begin
  ShellExecute(GetDesktopWindow(), 'open', PChar(FUpdateDownload), Nil, Nil, SW_SHOWNORMAL);
End;
End.