appwebupdater.pas

Delphi VCL Component Pack

//*************************************************************
//                       Application Updater                  *
//                                                            *
//               For Delphi 5,6, 7 , 2005, 2006               *
//                     Freeware Component                     *
//                            by                              *
//                     Eran Bodankin (bsalsa)                 *
//                     [e-mail]                      *
//                                                            *
//  Thanks to Snuki [e-mail] for his wonderful idea  *
//  Thanks to smot for English trans' and reformating         *
//     Documentation and updated versions:                    *
//               http://www.bsalsa.com                        *
//*************************************************************
{*******************************************************************************}
{LICENSE:
THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
AND DOCUMENTATION. [YOUR NAME] DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS,
AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. VSOFT SPECIFICALLY
DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.

You may use, change or modify the component under 3 conditions:
1. In your website, add a link to "http://www.bsalsa.com"
2. In your application, add credits to "Embedded Web Browser"
3. Mail me  ([e-mail]) any code change in the unit
   for the benefit of the other users.
{*******************************************************************************}

unit AppWebUpdater;

interface

{$I EWB.inc}

uses
   Controls, ActiveX, Windows, SysUtils, Classes, LibXmlParser, ComCtrls, UrlMon;

type
   TErrorMessage = (emCreateSubBackup, emFileCopyError, emXmlError, emFileNotExist, emCreateFolder,
      emExit, emUpdateVersion, emCurrentVersion, emDownloadInfo, emDownloadFiles,
      emBusy, emDelete, emError, emMatch);

   TOnError = procedure(Sender: TObject; ErrorCode: TErrorMessage; Parameter, ErrMessage: string) of object;
type
   TSuccessMessage = (smDone, smUpdateNotNeeded, smUpdateNeeded, smChecking);

   TOnSuccess = procedure(Sender: TObject; SuccessCode: TSuccessMessage; Parameter, SuccessMessage: string) of object;
type

   TOnChangeText = procedure(Sender: TObject; Text: string) of object;
   TProgressEvent = procedure(ProgressMax: integer; Position: integer) of object;
   TUpdateFormat = (ufStandard, ufNumbers);

type
   PUpRec = ^TUpRec;
   TUpRec = record
      dlFileName: string[40];
      dlDestination: string[40];
      dlTerminate: Boolean;
   end;

   TUpdatesList = record
      NoRestartList: TStringList;
      WithRestartList: TStringList;
   end;

   TWebUpdater = class(TComponent)
   private
      ApplicationFolder: string;
      Busy: Boolean;
      FAbout: string;
      FAppCurrentVer: Double;
      FApplicationName: string;
      FAppNewVer: Double;
      FAuthor: string;
      FBackupFolder: string;
      FBatFileName: string;
      FCaption: string;
      FCompany: string;
      FCursor: TCursor;
      FDeleteBatch: Boolean;
      FDeleteLog: Boolean;
      FDeleteUpdates: Boolean;
      FDeleteBackups: Boolean;
      FDeleteWebInFo: Boolean;
      FEmail: string;
      FEnabled: Boolean;
      FAbortMessage: string;
      FErrorReport: Boolean;
      FExeName: string;
      FErrorMessage: string;
      FLogData: TStrings;
      FLogDateStamp: Boolean;
      FLogFileName: TFileName;
      FLogHeader: string;
      FMatchDetails: boolean;
      FOnChangeText: TOnChangeText;
      FOnError: TOnError;
      FOnProgress: TProgressEvent;
      FOnSuccess: TOnSuccess;
      FOpenAppFolder: Boolean;
      FProgressBar: TProgressBar;
      FQuitOnError: Boolean;
      FSaveBackup: Boolean;
      FShowMessages: boolean;
      FShowChanges: Boolean;
      FShowPersonalDetails: Boolean;
      FShowUpdateFiles: Boolean;
      FStatusBar: TStatusBar;
      FSuccessMessageText: string;
      FUpdateFormat: TUpdateFormat;
      FUpdateInFoText: TStringList;
      FUpdateText: TStringList;
      FUpdatesFolder: string;
      FWebInFoFileName: string;
      FWebURL: string;
      XmlFile: string;
      NeedTerminate: boolean;
      OldCaption: string;
      OldCursor: TCursor;
      XmlParser: TXMLParser;
      function Check_CreateFolder(FolderName: string): boolean;
      function CheckVersionNum(): boolean;
      function CopyFiles(Source, Destination, FileName: string): boolean;
      function CreateSubBackupFolder(): boolean;
      function DownloadFile(SourceFile, DestFile: string): Boolean;
      function DownloadWebUpdates(): boolean;
      function GetXmlData(): boolean;
      function GetXmlHead(): boolean;
      function GetXmlTag(const TagName: string): boolean;
      function ParseXML(): boolean;
      function PerformMatchDetails(aString, bString: string): boolean;
      function ProcessBatch(): boolean;
      procedure AddLog(text: string);
      procedure CleanUp();
      procedure FinishHandler();
      procedure InitialUpdating();
      procedure ProcessFolderNames();
      procedure RestartApplication();
      procedure RestoreAppControls();
      procedure SetAbout(Value: string);
      procedure SetUpdateInfoText(Value: TstringList);
      procedure UpdateAppControls();
      procedure UpdateInfo();
      procedure UpdateProgressControls(ProgMax, Pos: integer);
      procedure UpdateTextControls(txt: string);
      procedure WriteLog();
      procedure ExitError(ErrString: string);
      procedure ExitNoUpdateFound();
      procedure ExitMatch();
      procedure ExitOK();
      procedure ExitUser();
      procedure ErrMessagesHandler(pErrCode: TErrorMessage; Parameter: string = '');
      procedure SuccessMessagesHandler(pSuccessCode: TSuccessMessage; Parameter: string = '');

   protected
      function GetFullLogFileName: TFileName;
      procedure CloseLog();
      procedure OpenLog();
      procedure SetLogData(Value: TStrings);

   public
      Quit: boolean;
      constructor Create(AOwner: TComponent); override;
      destructor Destroy; override;
      function CheckBusyState: boolean;
      function DeleteFiles(FileName: string): Boolean;
      function DeleteFolder(FolderName: string): Boolean;
      function OpenFolder(FolderName: string): Boolean;
      function Start: Boolean;
      procedure ClearLog();
      procedure Stop();
      procedure SendErrorReport();

   published
      property About: string read FAbout write SetAbout;
      property AbortMessage: string read FAbortMessage write FAbortMessage;
      property AppCurrentVer: Double read FAppCurrentVer write FAppCurrentVer;
      property ApplicationName: string read FApplicationName write FApplicationName;
      property Author: string read FAuthor write FAuthor;
      property BackupFolder: string read FBackupFolder write FBackupFolder;
      property Caption: string read FCaption write FCaption;
      property Company: string read FCompany write FCompany;
      property Cursor: TCursor read FCursor write FCursor default crAppStart;
      property DeleteOldBackupOnInit: Boolean read FDeleteBackups write FDeleteBackups default False;
      property DeleteBatchFileOnComplete: Boolean read FDeleteBatch write FDeleteBatch default True;
      property DeleteLogOnComplete: Boolean read FDeleteLog write FDeleteLog default True;
      property DeleteUpdatesOnComplete: Boolean read FDeleteUpdates write FDeleteUpdates default True;
      property DeleteWebInfoFileOnComplete: Boolean read FDeleteWebInfo write FDeleteWebInfo default True;
      property EMail: string read FEMail write FEMail;
      property Enabled: boolean read FEnabled write FEnabled default True;
      property ErrorMessage: string read FErrorMessage write FErrorMessage;
      property FullLogFileName: TFileName read GetFullLogFileName;
      property LogAddTime: Boolean read FLogDateStamp write FLogDateStamp;
      property LogData: TStrings read FLogData write setLogData;
      property LogFileName: TFileName read FLogFileName write FLogFileName;
      property LogHeaderText: string read FLogHeader write FLogHeader;
      property MatchDetails: boolean read FMatchDetails write FMatchDetails default True;
      property MailErrorReport: boolean read FErrorReport write FErrorReport default True;
      property OnChangeText: TOnChangeText read FOnChangeText write FOnChangeText;
      property OnError: TOnError read FOnError write FOnError;
      property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
      property OnSuccess: TOnSuccess read FOnSuccess write FOnSuccess;
      property OpenAppFolderOnComplete: Boolean read FOpenAppFolder write FOpenAppFolder default False;
      property ProgressBar: TProgressBar read FProgressBar write FProgressBar;
      property QuitOnError: Boolean read FQuitOnError write FQuitOnError default True;
      property SaveBackup: Boolean read FSaveBackup write FSaveBackup default True;
      property ShowUserMessages: boolean read FShowMessages write FShowMessages default True;
      property ShowChangeLog: boolean read FShowChanges write FShowChanges default True;
      property ShowPersonalDetails: boolean read FShowPersonalDetails write FShowPersonalDetails default True;
      property ShowUpdateFilesList: boolean read FShowUpdateFiles write FShowUpdateFiles default False;
      property StatusBar: TStatusBar read FStatusBar write FStatusBar;
      property SuccessMessageText: string read FSuccessMessageText write FSuccessMessageText;
      property UpdateFormat: TUpdateFormat read FUpdateFormat write FUpdateFormat default ufNumbers;
      property UpdateInfoText: TStringList read FUpdateInfoText write SetUpdateInfoText;
      property UpdatesFolder: string read FUpdatesFolder write FUpdatesFolder;
      property WebInfoFileName: string read FWebInfoFileName write FWebInfoFileName;
      property WebURL: string read FWebURL write FWebURL;

   end;

type
   TDownloadCallback = class(TInterfacedObject, IBindStatusCallback)
   public
      Quit: boolean;
      ProgressMax: integer;
      Position: integer;
      function OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult; stdcall;
      function GetPriority(out nPriority): HResult; stdcall;
      function OnLowResource(reserved: DWORD): HResult; stdcall;
      function OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG;
         szStatusText: LPCWSTR): HResult; stdcall;
      function OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult; stdcall;
      function GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo): HResult; stdcall;
      function OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD; Formatetc: PFormatEtc;
         stgmed: PStgMedium): HResult; stdcall;
      function OnObjectAvailable(const iid: TGUID; punk: IUnknown): HResult; stdcall;
   end;

implementation

uses
   Forms, Messages, Dialogs, ShellAPI;

var
   OnProgressStatusList: TStringList;
   logFile: TextFile;
   Dcb: TDownloadCallback;
   UpdateRec: TUpdatesList;

const
   LineBrk = #10 + #13;
   LineSpc = '                  ';

///////////--- DownloadCallback Part --------///////////////

function TDownloadCallback.GetPriority(out nPriority): HResult; stdcall;
begin
   Result := E_NOTIMPL;
end;

function TDownloadCallback.OnLowResource(reserved: DWORD): HResult; stdcall;
begin
   Result := E_NOTIMPL;
end;

function TDownloadCallback.OnStartBinding(dwReserved: DWORD;
   pib: IBinding): HResult; stdcall;
begin
   Position := 0;
   ProgressMax := 100;
   Result := S_OK;
end;

function TDownloadCallback.OnProgress(ulProgress, ulProgressMax,
   ulStatusCode: ULONG; szStatusText: LPCWSTR): HResult; stdcall;
begin
   OnProgressStatusList := TStringList.Create;
   ulProgressMax := 100;
   ProgressMax := ulProgressMax;
   Position := ulProgress;
   OnProgressStatusList.Add(Format('[ %d]:: %s - %d:%d', [ulStatusCode,
      string(szStatusText),
         ulProgress,
         ulProgressMax]));
   OnProgressStatusList.Add(szStatusText);
   OnProgressStatusList.Add('Progress:= ' + IntToStr(ulProgress) + ':  '
      + IntToStr(ulProgressMax));
   OnProgressStatusList.Add('Status:= ' + SzStatusText);
   OnProgressStatusList.Add('');
   case ulStatusCode of
      1: OnProgressStatusList.Add('BINDSTATUS_FINDINGRESOURCE');
      2: OnProgressStatusList.Add('BINDSTATUS_CONNECTING');
      3: OnProgressStatusList.Add('BINDSTATUS_REDIRECTING');
      4: OnProgressStatusList.Add('BINDSTATUS_BEGINDOWNLOADDATA');
      5: OnProgressStatusList.Add('BINDSTATUS_DOWNLOADINGDATA');
      6: OnProgressStatusList.Add('BINDSTATUS_ENDDOWNLOADDATA ');
      7: OnProgressStatusList.Add('BINDSTATUS_BEGINDOWNLOADCOMPONENTS');
      8: OnProgressStatusList.Add('BINDSTATUS_INSTALLINGCOMPONENTS');
      9: OnProgressStatusList.Add('BINDSTATUS_ENDDOWNLOADCOMPONENTS');
      10: OnProgressStatusList.Add('BINDSTATUS_USINGCACHEDCOPY');
      11: OnProgressStatusList.Add('BINDSTATUS_SENDINGREQUEST');
      12: OnProgressStatusList.Add('BINDSTATUS_CLASSIDAVAILABLE');
      13: OnProgressStatusList.Add('BINDSTATUS_MIMETYPEAVAILABLE');
      14: OnProgressStatusList.Add('BINDSTATUS_CACHEFILENAMEAVAILABLE');
   end;
   if Quit then
      Result := E_ABORT
   else
      Result := S_OK;
end;

function TDownloadCallback.OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult; stdcall;
begin
   Result := E_NOTIMPL;
end;

function TDownloadCallback.GetBindInfo(out grfBINDF: DWORD;
   var bindinfo: TBindInfo): HResult; stdcall;
begin
   Result := E_NOTIMPL;
end;

function TDownloadCallback.OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD;
   Formatetc: PFormatEtc; stgmed: PStgMedium): HResult; stdcall;
begin
   Result := E_NOTIMPL;
end;

function TDownloadCallback.OnObjectAvailable(const iid: TGUID;
   punk: IUnknown): HResult; stdcall;
begin
   Result := E_NOTIMPL;
end;
///////////---End of DownloadCallback Part --------///////////////

///////////---Logger Part --------///////////////

procedure TWebUpdater.SetLogData(Value: TStrings);
begin
   FLogData.Assign(Value);
end;

function TWebUpdater.GetFullLogFileName: TFileName;
begin
   if (pos('\', FLogFileName) > 0) or
      (pos(':', FLogFileName) > 0) or
      (pos('/', FLogFileName) > 0) then
      begin
         Result := LogFileName;
      end
   else
      begin
         Result := ExtractFilePath(Application.Exename) + LogFileName;
      end;
end;

procedure TWebUpdater.WriteLog();
var
   i: Integer;
begin
   try
      OpenLog;
      UpdateProgressControls(100, 20);
      if FLogDateStamp then
         begin
            WriteLn(logFile, DateToStr(Date) + ' ' + TimeToStr(Now));
         end;
      if (FLogHeader > '') then
         begin
            WriteLn(logFile, FLogHeader);
         end;
      for i := 0 to (FLogData.Count - 1) do
         begin
            WriteLn(logFile, FLogData[i]);
         end;
   finally
      CloseLog;
   end;
end;

procedure TWebUpdater.ClearLog();
begin
   AssignFile(logFile, FullLogFileName);
   try
      ReWrite(logFile);
   finally