appwebupdater.pas

Delphi VCL Component Pack

                                             UpdateRec.WithRestartList.AddObject(UpdRec.dlFileName, Pointer(UpdRec));
                                             AddLog('Adding files which require restart into the update list: ' + UpdRec.dlFileName);
                                             Result := True;
                                          end
                                       else
                                          if Trim(Node.Value) = 'no' then
                                             begin
                                                UpdRec.dlTerminate := False;
                                                UpdateRec.NoRestartList.AddObject(UpdRec.dlFileName, Pointer(UpdRec));
                                                AddLog('Adding files into the update list: ' + UpdRec.dlFileName);
                                                Result := True;
                                             end;
                                    end;
                        end;
                  end;
               MS.Free;
            end;
      end;
end;

function TWebUpdater.ProcessBatch(): boolean;
var
   slBatchFile: TStringList;
   Destination, FileName: string;
   i: integer;
   UpdRecRestart: PUpRec;
begin
   Result := False;
   if Quit then
      begin
         ExitUser();
         Exit;
      end;
   AddLog('Creating a batch file: ' + FBatFileName);
   slBatchFile := TStringList.Create;
   slBatchFile.Add('@Echo On');
   slBatchFile.Add(':again');
   for i := 0 to UpdateRec.WithRestartList.Count - 1 do
      begin
         UpdRecRestart := PUpRec(UpdateRec.WithRestartList.Objects[i]);
         FileName := Trim(UpdRecRestart.dlFileName);
         Destination := Trim(UpdRecRestart.dlDestination);
         if Destination <> '' then
            slBatchFile.Add('if not exist "' + Destination + '" MD " ' + Destination + '"');
         slBatchFile.Add('del "' + Destination + FileName + '"');
         slBatchFile.Add('if exist "' + Destination + FileName + '" goto again');
         slBatchFile.Add('copy "' + FUpdatesFolder + FileName + '" "' + Destination + FileName + '"');
         slBatchFile.Add('if not exist "' + Destination + FileName + '" ' + ' copy "' + FBackupFolder + '" "' + Destination + FileName + '"');
      end;
   slBatchFile.Add('call "' + Application.ExeName + '"');
   if FDeleteUpdates then
      slBatchFile.Add('RMDIR /S /Q "' + FUpdatesFolder + '"');
   if FDeleteBatch then
      slBatchFile.Add('del "' + FBatFileName + '"');
   slBatchFile.SaveToFile(fBatFileName);
   AddLog('Batch File Commands: ' + LineBrk + LineBrk + slBatchFile.Text);
   slBatchFile.Free;
   Result := True;
end;

function TWebUpdater.PerformMatchDetails(aString, bString: string): boolean;
begin
   AddLog('Matching details: ' + aString + ' to: ' + bString);
   if aString = bString then
      begin
         AddLog('Result: MATCH.');
         Result := True;
      end
   else
      begin
         AddLog('Result: No match found!');
         Result := False;
      end;
end;

procedure TWebUpdater.RestartApplication();
var
   ProcessInfo: TProcessInformation;
   StartupInfo: TStartupInfo;
   Res: DWORD;
begin
   if Quit then
      begin
         ExitUser();
         Exit;
      end;
   AddLog('Creating a process to run the batch file.');
   FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
   StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
   StartupInfo.wShowWindow := SW_HIDE;
   if CreateProcess(nil, PChar(fBatFileName), nil, nil, False,
      IDLE_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then
      begin
         AddLog('Restarting.... Hold On.');
         CloseHandle(ProcessInfo.hThread);
         GetExitCodeProcess(ProcessInfo.hProcess, Res);
         CloseHandle(ProcessInfo.hProcess);
         PostMessage(Application.Handle, WM_CLOSE, 0, 0);
      end
   else
      begin
         AddLog('An error ocurred while trying to run the cmd file. ');
         raise
            Exception.CreateFmt('An error ocurred while trying to run the cmd file, error %d', [GetLastError()]);
      end;
end;

procedure TWebUpdater.FinishHandler();
begin
   RestoreAppControls();
   UpdateProgressControls(100, 0);
   FUpdateInfoText.Clear();
   CleanUp();
   Busy := False;
end;

procedure TWebUpdater.ExitOK();
begin
   SuccessMessagesHandler(smDone);
   if FOpenAppFolder then
      OpenFolder(ApplicationFolder);
   FinishHandler();
end;

procedure TWebUpdater.ExitError(ErrString: string);
begin
   ErrMessagesHandler(emError, ErrString);
   FinishHandler();
end;

procedure TWebUpdater.ExitMatch();
begin
   ErrMessagesHandler(emMatch);
   FinishHandler();
end;

procedure TWebUpdater.ExitUser();
begin
   ErrMessagesHandler(emExit);
   FinishHandler();
end;

procedure TWebUpdater.ExitNoUpdateFound();
begin
   UpdateTextControls('There are no new available updates. ');
   FinishHandler();
end;

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

///////////////// public procedures//////////////

function TWebUpdater.CheckBusyState(): boolean;
begin
   Result := False;
   if Quit then
      begin
         ExitUser();
         Exit;
      end;
   if Busy then
      begin
         ErrMessagesHandler(emBusy);
         Result := True;
      end
   else
      AddLog('Updater is running... ');
end;

procedure TWebUpdater.CleanUp();
begin
   Addlog('Cleaning unnecessary files. ');
   if FDeleteWebInfo then
      DeleteFiles(Trim(fWebInfoFileName));
   if (fDeleteUpdates and not NeedTerminate) then
      DeleteFolder(Trim(fUpdatesFolder));
   if FDeleteLog then
      DeleteFiles(Trim(fLogFileName));
end;

function TWebUpdater.DownloadWebUpdates(): boolean;
var
   i: integer;
   DLfilename, dest: string;
   UpdRec, UpdRecRestart: PUpRec;
begin
   Result := False;
   if Quit then
      begin
         ExitUser();
         Exit;
      end;
   if UpdateRec.NoRestartList.Count > 0 then
      begin
         for i := 0 to UpdateRec.NoRestartList.Count - 1 do
            begin
               UpdRec := PUpRec(UpdateRec.NoRestartList.Objects[i]);
               if (Trim(UpdRec.dlFileName) <> '') then
                  begin
                     if not FileExists(fUpdatesFolder + Trim(UpdateRec.NoRestartList[i])) then
                        begin
                           DLfilename := FWebURL + '/' + (Pchar(Trim(UpdateRec.NoRestartList[i])));
                           Dest := FUpdatesFolder + Trim(UpdateRec.NoRestartList[i]);
                           DownloadFile(DLfilename, Dest);
                        end
                     else
                        begin
                           if Dest = '' then
                              Dest := FUpdatesFolder + ' folder.';
                           AddLog('File name: ' + Trim(UpdateRec.NoRestartList[i]) +
                              ' already exists in ' + Dest + ' (OverWriting.)');
                        end;
                  end;
            end;
      end;
   if UpdateRec.WithRestartList.Count > 0 then
      begin
         for i := 0 to UpdateRec.WithRestartList.Count - 1 do
            begin
               UpdRecRestart := PUpRec(UpdateRec.WithRestartList.Objects[i]);
               if (Trim(UpdRecRestart.dlFileName) <> '') then
                  begin
                     if not FileExists(fUpdatesFolder + Trim(UpdateRec.WithRestartList[i])) then
                        begin
                           DLfilename := FWebURL + '/' + (Pchar(Trim(UpdateRec.WithRestartList[i])));
                           Dest := FUpdatesFolder + Trim(UpdateRec.WithRestartList[i]);
                           DownloadFile(DLfilename, Dest);
                        end
                     else
                        begin
                           if Dest = '' then
                              Dest := FUpdatesFolder + ' folder.';
                           AddLog('File name: ' + Trim(UpdateRec.WithRestartList[i]) +
                              ' already exists in ' + Dest + ' (OverWriting.)');
                        end;
                  end;
            end;
      end;
end;

function TWebUpdater.Start(): boolean;
var
   i: integer;
   SM, st: string;
   UpdRec, UpdRecRestart: PUpRec;
begin
   Result := False;
   if not Enabled then
      Exit;
   CheckBusyState();
   Busy := True;
   InitialUpdating();
   if not ParseXML() then
      ExitError(fErrorMessage + 'parsing the xml file')
   else
      begin
         if FUpdateFormat = ufNumbers then
            if not CheckVersionNum then
               begin
                  ExitNoUpdateFound();
                  Exit;
               end;

         UpdateInfo();
         AddLog('XML Information: ' + LineBrk + FUpdateInfoText.Text);
         if FShowMessages then
            begin
               SM := FUpdateInfoText.Text;
               if MessageDlg(SM, mtCustom, [mbOK, mbAbort], 0) <> 1 then
                  begin
                     ExitUser();
                     Exit;
                  end;
            end;

         if Check_CreateFolder(fUpdatesFolder) then
            if FQuitOnError then
               begin
                  ExitError(fErrorMessage + 'creating updates folder');
                  Exit;
               end;
         if Check_CreateFolder(fBackupFolder) then
            if FQuitOnError then
               begin
                  ExitError(fErrorMessage + 'creating backup folder');
                  Exit;
               end;
         if CreateSubBackupFolder() then
            if FQuitOnError then
               begin
                  ExitError(fErrorMessage + 'creating sub backup folder');
                  Exit;
               end;

         DownloadWebUpdates();
      end;

   if UpdateRec.NoRestartList.Count > 0 then
      begin
         for i := 0 to UpdateRec.NoRestartList.Count - 1 do
            begin
               UpdRec := PUpRec(UpdateRec.NoRestartList.Objects[i]);
               if ((Trim(UpdRec.dlFileName) <> '') and (UpdRec.dlTerminate = False)) then
                  begin
                     if FSaveBackup then
                        begin
                           if FileExists(UpdRec.dlDestination + UpdRec.dlFileName) then
                              CopyFiles(UpdRec.dlDestination, FBackUpFolder,
                                 UpdRec.dlFileName);
                        end;

                     if Trim(UpdRec.dlFileName) <> '' then
                        begin
                           CopyFiles(fUpdatesFolder, UpdRec.dlDestination,
                              UpdRec.dlFileName);
                        end;
                  end;
            end;
      end;

   if UpdateRec.WithRestartList.Count > 0 then
      begin
         NeedTerminate := True;
         st := 'Some of the updates require a restart. ' + LineBrk +
            'Press "Yes" to restart now, or press "Abort" to run the ' +
            'updates checking later.';
         UpdateTextControls(st);
         if MessageDlg(st, mtCustom, [mbYes, mbAbort], 0) = 6 then
            begin
               for i := 0 to UpdateRec.WithRestartList.Count - 1 do
                  begin
                     UpdRecRestart := PUpRec(UpdateRec.WithRestartList.Objects[i]);
                     if ((Trim(UpdRecRestart.dlFileName) <> '') and
                        (UpdRecRestart.dlTerminate = True)) then
                        begin
                           if FSaveBackup then
                              begin
                                 if FileExists(UpdRecRestart.dlDestination +
                                    UpdRecRestart.dlFileName) then
                                    CopyFiles(UpdRecRestart.dlDestination, FBackUpFolder,
                                       UpdRecRestart.dlFileName);
                              end;
                        end;
                  end;
               if ProcessBatch() then
                  begin
                     RestartApplication();
                     ExitOK();
                  end;
            end
         else
            ExitUser();
      end;
   if ((UpdateRec.NoRestartList.Count > 0) and not (NeedTerminate)) then
      ExitOK();
   Busy := False;
   Result := not Busy;
end;

procedure TWebUpdater.SendErrorReport();
var
   emMail, emSubject: string;
   emBody: TStringList;
begin
   if FileExists(GetFullLogFileName) then
      begin
         embody := TStringList.Create;
         emBody.Clear;
         try
            emBody.LoadFromFile(GetFullLogFileName);
            emSubject := 'Updater Error Report';
            emMail := 'mailto:' + FEmail + '?subject=' + emSubject + '&body=' + emBody.Text;
            AddLog('Mailing Error Report.... Hold On.');
            ShellExecute(Forms.Application.Handle, 'open', PChar(emMail), nil, nil, SW_SHOWNORMAL);
         finally
            emBody.Free;
         end;
      end;
end;

procedure TWebUpdater.Stop();
begin
   if Busy then
      begin
         Quit := True;
         UpdateTextControls('Stopped (User Request).');
      end;
end;

///////////////// End of public procedures//////////////

end.