appwebupdater.pas

Delphi VCL Component Pack

      CloseFile(logFile);
   end;
end;

procedure TWebUpdater.OpenLog();
begin
   AssignFile(LogFile, FullLogFileName);
{$I-}
   Append(LogFile);
{$I+}
   if (IOResult <> 0) then
      begin
         try
            ReWrite(LogFile);
         except
            on E: Exception do
               begin
                  E.Message := 'Unable to create error log file: ' + LineBrk + FLogFileName +
                     LineBrk + E.Message;
                  raise;
               end;
         end;
      end;
end;

procedure TWebUpdater.CloseLog();
begin
   CloseFile(LogFile);
end;

procedure TWebUpdater.AddLog(text: string);
var
   Data: TStrings;
   i: Integer;
begin
   OpenLog;
   Data := TStringList.Create;
   try
      if FLogDateStamp then
         begin
            Data.Add(DateToStr(Date) + ' ' + TimeToStr(Now));
         end;
      if (FLogHeader > '') then
         begin
            Data.Add(FLogHeader);
         end;
      Data.Add(text);
      Data.Add('');
      for i := 0 to (Data.Count - 1) do
         begin
            WriteLn(logFile, Data[i]);
         end;
   finally
      CloseLog;
      Data.Free;
   end;
end;
///////////---End of Logger Part --------///////////

///////////---Messages Part --------///////////

procedure TWebUpdater.ErrMessagesHandler(pErrCode: TErrorMessage; Parameter: string);
var
   EM, st: string;
begin
   case pErrCode of
      emBusy: EM := 'Update procedure is running. Please wait';
      emCreateSubBackup: EM := FErrorMessage + ' trying to create the sub backup folder!';
      emCreateFolder: EM := FErrorMessage + ' trying to create the folder!';
      emFileCopyError: EM := FErrorMessage + ' trying to copy the file';
      emXMLError: EM := FErrorMessage + ' trying to parse the XML file!';
      emUpdateVersion: EM := FErrorMessage + ' trying to locate the update version number!';
      emCurrentVersion: EM := FErrorMessage + ' trying to locate the current version number!';
      emDownloadInfo: EM := FErrorMessage + ' downloading the update Info file!';
      emDownloadFiles: EM := FErrorMessage + ' downloading the updates!';
      emDelete: EM := FErrorMessage + ' trying to delete the file !';
      emFileNotExist: EM := FErrorMessage + ' trying to locate the source folder!';
      emExit: EM := FAbortMessage;
      emError: EM := 'Updates checking was canceled (An error has been found).';
      emMatch: EM := 'Security Alert!! '
         + LineBrk + FErrorMessage + 'trying to match the application '
            + 'details with the remote web site details!';
   end;
   if Parameter = '' then
      st := EM
   else
      st := EM + LineBrk + Parameter;
   UpdateTextControls(st);
   if Assigned(FOnError) then
      FOnError(Self, pErrCode, Parameter, EM);
   if FShowMessages then
      MessageDlg(st, mtError, [mbAbort], 0);
   if FErrorReport then
      SendErrorReport();
end;

procedure TWebUpdater.SuccessMessagesHandler(pSuccessCode: TSuccessMessage; Parameter: string);
var
   SM: string;
   Name: string;
begin
   Name := ExtractFileName(Application.ExeName);
   case pSuccessCode of
      smDone: SM := FSuccessMessageText;
      smUpdateNeeded: SM := 'A new update is available for: ' + Name;
      smUpdateNotNeeded: SM := 'Your application is up to date.';
      smChecking: SM := 'Checking for the latest release';
   end;
   UpdateTextControls(SM);
   if FShowMessages then
      MessageDlg(SM, mtInformation, [mbOK], 0);
   if Assigned(FOnSuccess) then
      FOnSuccess(Self, pSuccessCode, Parameter, SM);
end;
///////////---End Of Messages Part --------///////////

///////////---Component Part --------///////////

constructor TWebUpdater.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);
   FCursor := crAppStart;
   FAbortMessage := 'Aborted! (User request).';
   FAbout := 'Application Updater by bsalsa : [e-mail]';
   Busy := False;
   FAppCurrentVer := 0.001;
   FAppNewVer := 0.001;
   FBackupFolder := 'Backup\';
   FLogDateStamp := True;
   FWebURL := 'http://';
   FEnabled := True;
 // FFilesToUpdate        := TStringList.Create;
//  FFilesToUpdate.Duplicates := dupIgnore;
{$IFDEF DELPHI_6_UP}
//  FFilesToUpdate.CaseSensitive := False;
{$ENDIF}
   FLogData := TstringList.Create;
   FUpdateText := TstringList.Create;
   FDeleteUpdates := True;
   FDeleteWebInfo := True;
   FDeleteLog := True;
   FDeleteBatch := True;
   FErrorMessage := 'An error ocurred while ';
   FErrorReport := True;
   FMatchDetails := True;
   FQuitOnError := True;
   FSaveBackup := True;
   FShowMessages := True;
   FShowChanges := True;
   FShowPersonalDetails := True;
   FShowUpdateFiles := False;
   FSuccessMessageText := 'Update is done.';
   FUpdateInfoText := TStringList.Create;
   FUpdateInfoText.Duplicates := dupIgnore;
   FUpdatesFolder := 'Updates\';
   FOpenAppFolder := False;
   XmlParser := TXMLParser.Create;
   FLogFileName := 'Updater.txt';
   FWebInfoFileName := 'Updates.xml';
   FCaption := 'Checking for updates... Please wait.';
   FUpdateFormat := ufNumbers;
   Quit := False;

   UpdateRec.NoRestartList := TStringList.Create;
   UpdateRec.NoRestartList.Duplicates := dupIgnore;
   UpdateRec.WithRestartList := TStringList.Create;
   UpdateRec.WithRestartList.Duplicates := dupIgnore;
end;

destructor TWebUpdater.Destroy;
begin
   Stop();
   while Busy do
      begin
         Application.ProcessMessages();
      end;
   OnProgressStatusList.Free;
   FUpdateInfoText.Free;
   FUpdateText.Free;
   XmlParser.Free;
   FLogData.Free;
   UpdateRec.WithRestartList.Free;
   UpdateRec.NoRestartList.Free;
   inherited Destroy;
end;

procedure TWebUpdater.SetAbout(Value: string);
begin
   Exit;
end;

procedure TWebUpdater.SetUpdateInfoText(Value: TstringList);
begin
   FUpdateInfoText.Assign(Value);
end;

///////////---End Of Component Part --------///////////

///////////////// private Updates procedures //////////////

procedure TWebUpdater.UpdateInfo();
begin
   if Quit then
      begin
         ExitUser();
         Exit;
      end;
   FUpdateInfoText.Add('A new update is available for ' + FApplicationName + '!' + LineBrk);
   if FShowPersonalDetails then
      begin
         if Trim(fAuthor) <> '' then
            FUpdateInfoText.Add('The update is available by: ' + LineBrk +
               LineBrk + 'Author:  ' + Trim(fAuthor));
         if Trim(fCompany) <> '' then
            FUpdateInfoText.Add('Company:  ' + Trim(fCompany));
         if Trim(fEMail) <> '' then
            FUpdateInfoText.Add('Email:  ' + Trim(fEMail));
      end;
   if FShowChanges then
      begin
         if FUpdateText.Text <> '' then
            FUpdateInfoText.Add(LineBrk + 'Update Changes: ' + FUpdateText.Text);
      end;
   if FShowUpdateFiles then
      begin
         FUpdateInfoText.Add(LineBrk + 'The files that will be updated are: ' + LineBrk
            + LineBrk + UpdateRec.NoRestartList.Text + UpdateRec.WithRestartList.Text)
      end;
   FUpdateInfoText.Add(LineBrk + 'Press "OK" to update ' + FApplicationName +
      ' or press "Abort".');
end;

procedure TWebUpdater.UpdateProgressControls(ProgMax, Pos: integer);
begin
   if Assigned(fProgressBar) then
      begin
         FProgressBar.Max := ProgMax;
         FProgressBar.Position := Pos;
      end;
   if Assigned(FOnProgress) then
      FOnProgress(ProgMax, Pos);
end;

procedure TWebUpdater.UpdateTextControls(txt: string);
begin
   AddLog(txt);
   if Assigned(fOnChangeText) then
      FOnChangeText(Self, txt);
   if Assigned(fStatusbar) then
      FStatusbar.SimpleText := txt;
end;

procedure TWebUpdater.UpdateAppControls();
begin
   AddLog('Updating Application Controls');
   OldCaption := Forms.Application.MainForm.Caption;
   Forms.Application.MainForm.Caption := FCaption;
   OldCursor := Screen.Cursor;
   Screen.Cursor := FCursor;
end;

procedure TWebUpdater.RestoreAppControls();
begin
   Screen.Cursor := OldCursor;
   Forms.Application.MainForm.Caption := OldCaption;
end;

///////////////// End of private Updates procedures  //////////////

///////////////// private procedures //////////////

function TWebUpdater.CheckVersionNum(): boolean;
var
   iNew, ICur: integer;
   Info: string;
begin
   Result := False;
   if Quit then
      begin
         ExitUser();
         Exit;
      end;
   if (fAppCurrentVer < 0) or (fAppCurrentVer > 100000) then
      begin
         AddLog('error has been found in the current version definition');
         ErrMessagesHandler(emCurrentVersion, ' Definition');
      end;
   if (fAppNewVer < 0) or (fAppNewVer > 100000) then
      begin
         AddLog('error has been found in the new version definition');
         ErrMessagesHandler(emUpdateVersion, ' Definition');
      end;
   iNew := StrToInt(FloatToStr(fAppNewVer * 1000));
   iCur := StrToInt(FloatToStr(fAppCurrentVer * 1000));
   if (iNew > iCur) then
      begin
         AddLog('A new update is available. ' + info);
         UpdateTextControls('A new update is available ');
         Result := True;
      end
   else
      begin
         UpdateTextControls('Your application is up to date.');
      end;
end;

function TWebUpdater.Check_CreateFolder(FolderName: string): boolean;
begin
   Result := False;
   if Quit then
      begin
         ExitUser();
         Exit;
      end;
{$IFDEF DELPHI_6_UP}
   if not (DirectoryExists(FolderName)) then
{$ENDIF}
      begin
         if not (CreateDir(FolderName)) then
            begin
               AddLog('Error Creating ' + FolderName + ' folder!');
               ErrMessagesHandler(emCreateFolder, FolderName);
               Result := True;
            end
         else
            AddLog('Creating ' + FolderName + ' folder.');
      end
{$IFDEF DELPHI_6_UP}
   else
      AddLog('Checking if folder ' + FolderName + ' exists. --> OK.');
{$ENDIF}
end;

function TWebUpdater.CopyFiles(Source, Destination, FileName: string): boolean;
begin
   Result := False;
   if Quit then
      begin
         ExitUser();
         Exit;
      end;
   UpdateProgressControls(100, 40);
   Source := (ApplicationFolder + Source);
   Destination := (ApplicationFolder + Destination);
   Check_CreateFolder(Destination);
   if FileExists(Source + FileName) then
      begin
         if not (CopyFile(PAnsiChar(Source + FileName),
            PAnsiChar(Destination + FileName), False)) then
            begin
               AddLog('Error copy file name: ' + Source + FileName +
                  '  ---> to: ' + Destination + FileName);
               ErrMessagesHandler(emFileCopyError, FileName);
               Result := True;
            end
         else
            AddLog('The File ' + Source + FileName +
               LineBrk + ' --> has been copied to: ' + Destination + FileName);
      end
   else
      begin
         ErrMessagesHandler(emFileNotExist, FileName);
         AddLog('File doesn'' t exist: ' + Source + FileName + ' !');
      end;
end;

function TWebUpdater.CreateSubBackupFolder: boolean;
begin
   Result := False;
   if Quit then
      begin
         ExitUser();
         Exit;
      end;
   FBackupFolder := FBackupFolder + FormatDateTime('yyyy_MM_dd_HH_mm_ss', Now) + '\';
   if FSaveBackup then
      if not CreateDir(fBackupFolder) then
         begin
            ErrMessagesHandler(emCreateSubBackup, FBackupFolder);
            AddLog('Error creating ' + FBackupFolder + ' folder.');
            Result := True;
         end
      else
         AddLog('Creating ' + FBackupFolder + ' folder. --> OK.');
end;

function TWebUpdater.GetXmlHead(): boolean;
begin
   Result := False;
   if Quit then
      begin
         ExitUser();
         Exit;
      end;
   while XmlParser.Scan() do