jvcldata.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JVCLData.pas, released on 2004-03-29.

The Initial Developer of the Original Code is Andreas Hausladen
(Andreas dott Hausladen att gmx dott de)
Portions created by Andreas Hausladen are Copyright (C) 2004 Andreas Hausladen.
All Rights Reserved.

Contributor(s): -

You may retrieve the latest version of this file at the Project JEDI's JVCL
home page, located at http://jvcl.sourceforge.net

Known Issues:
-----------------------------------------------------------------------------}
// $Id: JVCLData.pas,v 1.29 2005/01/27 13:03:13 ahuser Exp $

unit JVCLData;

{$I jvcl.inc}

interface

uses
  Windows, Registry, SysUtils, Classes, Contnrs,
  JVCLConfiguration, DelphiData, PackageUtils, Intf, GenerateUtils,
  IniFiles, JCLData;

const
  sPackageGeneratorFile = 'devtools\bin\pgEdit.xml';
  sDxgettextRegKey = '\bplfile\Shell\Extract strings\Command';
  sJvclIncFile = '%s\common\jvcl.inc';
  sBCBIncludeDir = '%s\Include\Vcl';

type
  TJVCLData = class;
  TTargetConfig = class;

  TInstallMode = set of TPackageGroupKind;

  TDeinstallProgressEvent = procedure(Sender: TObject; const Text: string;
    Position, Max: Integer) of object;
  TDeleteFilesEvent = procedure(TargetConfig: TTargetConfig) of object;

  TTargetConfig = class(TComponent, ITargetConfig) // TComponent <-> TInterfacedObject
  private
    FOwner: TJVCLData;
    FTarget: TCompileTarget;
    FInstalledJVCLVersion: Integer;
    FDefaultJCLDir: string;
    FJCLDir: string;
    FDefaultHppDir: string;
    FHppDir: string;
    FMissingJCL: Boolean;
    FOutdatedJCL: Boolean;
    FCompiledJCL: Boolean;
    FInstallJVCL: Boolean;

    FDeveloperInstall: Boolean;
    FCleanPalettes: Boolean;
    FBuild: Boolean;
    FCompileOnly: Boolean;
    FDebugUnits: Boolean;
    FAutoDependencies: Boolean;

    FInstallMode: TInstallMode;
    FFrameworks: TJVCLFrameworks;
    FDcpDir: string;
    FBplDir: string;
    FGenerateMapFiles: Boolean;

    FJVCLConfig: TJVCLConfig;

    procedure SetInstallMode(const Value: TInstallMode);
    function GetFrameworkCount: Integer;
    function GetDxgettextDir: string;
    function GetDeveloperInstall: Boolean;
    function GetGenerateMapFiles: Boolean;
    procedure SetJCLDir(const Value: string);
    function GetJVCLConfig: TJVCLConfig;
  private
    { ITargetConfig }
    function GetInstance: TObject;
    function GetJVCLPackagesXmlDir: string;
    function GetJVCLDir: string;
    function GetJVCLPackagesDir: string;

    function GetTargetSymbol: string;
    function GetAutoDependencies: Boolean;
    function GetBuild: Boolean;
    function GetUnitOutDir: string;
    function GetDebugUnits: Boolean;
    function GetCompileOnly: Boolean;

    function GetTarget: TCompileTarget;
    function GetJCLDir: string;
    function GetHppDir: string;
    function GetBplDir: string;
    function GetDcpDir: string;
  protected
    procedure Init; virtual;
    procedure DoCleanPalette(reg: TRegistry; const Name: string;
      RemoveEmptyPalettes: Boolean);
    function RegisterProjectGroupToIDE(ProjectGroup: TProjectGroup): Boolean;

    procedure UpdateOptions;
    procedure EnableOption(const Name: string; Enable: Boolean);
  public
    property Target: TCompileTarget read GetTarget;
    property Owner: TJVCLData read FOwner;
  public
    constructor Create(AOwner: TJVCLData; ATarget: TCompileTarget); reintroduce;
    destructor Destroy; override;
    procedure Load;
    procedure Save;
    procedure CleanJVCLPalette(RemoveEmptyPalettes: Boolean);
    procedure DeinstallJVCL(Progress: TDeinstallProgressEvent;
      DeleteFiles: TDeleteFilesEvent);
    function RegisterToIDE: Boolean;

    function CanInstallJVCL: Boolean;
      // CanInstallJVCL returns False when the target is not up to date or
      // no JCL was found.

    function IsUpToDate: Boolean;
      // IsUpToDate returns False when the (Borland) updates for this target
      // are not installed.

    function IsOldVersionInstalled: Boolean;
      // IsOldVersionInstalled returns true if an older JVCL version is
      // installed.

    function GetBpgFilename(Personal: Boolean; Kind: TPackageGroupKind): string;
      // BpgFilename returns the filename of the ProjectGroup that is used

    procedure ResetPackagesSettings(ProjectGroup: TProjectGroup);
      // ResetPackagesSettings sets the install property for each package target
      // to its registry setting of the current IDE target.
    procedure SavePackagesSettings(ProjectGroup: TProjectGroup);
      // SavePackagesSettings saves the runtime packages state to an .ini file.

    property TargetSymbol: string read GetTargetSymbol;
      // TargetSymbol returns the symbol that is used in the xml files for this
      // target.

    property UnitOutDir: string read GetUnitOutDir;
      // UnitOutDir specifies the JVCL directory where the .dcu should go.
    property BplDir: string read GetBplDir write FBplDir;
      // BPL directory for this target
    property DcpDir: string read GetDcpDir write FDcpDir;
      // DCP directory for this target

    property DxgettextDir: string read GetDxgettextDir;
      // Directory where dxgettext is installed or ''. (special handling for Delphi/BCB 5)

    property InstalledJVCLVersion: Integer read FInstalledJVCLVersion;
      // InstalledJVCLVersion returns the version of the installed JVCL.

    property MissingJCL: Boolean read FMissingJCL;
      // MissingJCL is True when no JCL is installed and no JCL directoy was
      // found that could be installed.

    property OutdatedJCL: Boolean read FOutdatedJCL;
      // OutdatedJCL is True if no jcl\source\common\windows\win32api directory
      // exists which means that the JCL is too old for the JVCL.

    property CompiledJCL: Boolean read FCompiledJCL;
      // CompiledJCL is True if D/CJcl.dcp and D/CJclVcl.dcp exist for this
      // target.

    property Frameworks: TJVCLFrameworks read FFrameworks;
      // Frameworks contains all possible package groups.

    property FrameworkCount: Integer read GetFrameworkCount;
      // FrameworkCount returns the number of available frameworks for this
      // target.

    property JVCLConfig: TJVCLConfig read GetJVCLConfig;
      // JVCLConfig returns the confiuration
  public
    property InstallJVCL: Boolean read FInstallJVCL write FInstallJVCL;
      // InstallJVCL specifies if the JVCL should be installed on this target.

    property InstallMode: TInstallMode read FInstallMode write SetInstallMode;
      // InstallMode specifies if the JVCL only,  JVCL and JVCLX or JVCLX only
      // should be installed.

    property DebugUnits: Boolean read GetDebugUnits write FDebugUnits;
      // if DebugUnits is True the units will be compiled in debug mode, too.
      // (Delphi only) [NOT USED IN THE JVCL DUE TO jvcl.inc SETTINGS]

    property GenerateMapFiles: Boolean read GetGenerateMapFiles write FGenerateMapFiles;
      // if GenerateMapFiles is True the compiler generates .map files for each package

    property Build: Boolean read GetBuild write FBuild;
      // if Build is True the packages are built instead of make.

    property CompileOnly: Boolean read GetCompileOnly write FCompileOnly;
      // if CompileOnly is True the desigtime packages are not registered to the
      // IDE.

    property AutoDependencies: Boolean read GetAutoDependencies write FAutoDependencies;
      // if AutoDependencies it True the make file for the project groups will
      // contain auto dependency information for faster compilation.

    property DeveloperInstall: Boolean read GetDeveloperInstall write FDeveloperInstall;
      // DevelopInstall: add the \run directory to the library path.

    property CleanPalettes: Boolean read FCleanPalettes write FCleanPalettes;
      // CleanPalettes specifies if the JVCL components should be removed from
      // the component palettes before installation.

    property JCLDir: string read GetJCLDir write SetJCLDir;
      // JCLDir specifies the directory where the JCL is.

    property HppDir: string read GetHppDir write FHppDir;
      // HppDir: (for BCB installation) specifies where the generated .hpp files
      // should go.
  end;

  TJVCLData = class(TObject)
  private
    FConfigs: array of TTargetConfig;
    FTargets: TCompileTargetList;
    FIsDxgettextInstalled: Boolean;
    FDxgettextDir: string;
    FJVCLDir: string;
    FDeleteFilesOnUninstall: Boolean;
    FCompileJclDcp: Boolean;
    FVerbose: Boolean;
    FIgnoreMakeErrors: Boolean;

    function GetTargetConfig(Index: Integer): TTargetConfig;
    function GetJVCLDir: string;
    function GetCleanPalettes: Integer;
    procedure SetCleanPalettes(Value: Integer);
    function GetDeveloperInstall: Integer;
    procedure SetDeveloperInstall(Value: Integer);
    function GetJVCLPackagesDir: string;
    function GetJVCLPackagesXmlDir: string;
    function GetBuild: Integer;
    procedure SetBuild(Value: Integer);
    function GetCompileOnly: Integer;
    procedure SetCompileOnly(const Value: Integer);
    function GetOptionState(Index: Integer): Integer;
    function GetGenerateMapFiles: Integer;
    procedure SetGenerateMapFiles(const Value: Integer);
    function GetDebugUnits: Integer;
    procedure SetDebugUnits(const Value: Integer);
  protected
    function JvclIncFilename: string;
    procedure Init; virtual;
  public
    constructor Create;
    destructor Destroy; override;

    procedure SaveTargetConfigs;
    function FindTargetConfig(const TargetSymbol: string): TTargetConfig;
    function IsJVCLInstalledAnywhere(MinVersion: Integer): Boolean;

    property DxgettextDir: string read FDxgettextDir;
    property IsDxgettextInstalled: Boolean read FIsDxgettextInstalled;

    property JVCLDir: string read GetJVCLDir;
    property JVCLPackagesDir: string read GetJVCLPackagesDir;
    property JVCLPackagesXmlDir: string read GetJVCLPackagesXmlDir;

    property DeveloperInstall: Integer read GetDeveloperInstall write SetDeveloperInstall;
    property DebugUnits: Integer read GetDebugUnits write SetDebugUnits;
    property CleanPalettes: Integer read GetCleanPalettes write SetCleanPalettes;
    property Build: Integer read GetBuild write SetBuild;
    property CompileOnly: Integer read GetCompileOnly write SetCompileOnly;
    property GenerateMapFiles: Integer read GetGenerateMapFiles write SetGenerateMapFiles;

    property DeleteFilesOnUninstall: Boolean read FDeleteFilesOnUninstall write FDeleteFilesOnUninstall default True;
    property CompileJclDcp: Boolean read FCompileJclDcp write FCompileJclDcp default True;
    property Verbose: Boolean read FVerbose write FVerbose default False;
    property IgnoreMakeErrors: Boolean read FIgnoreMakeErrors write FIgnoreMakeErrors default False;

    property TargetConfig[Index: Integer]: TTargetConfig read GetTargetConfig;
    property Targets: TCompileTargetList read FTargets;
  end;

const
  TargetTypes: array[Boolean] of string = ('D', 'C'); // do not localize

implementation

uses
  Utils, CmdLineUtils;

resourcestring
  RsComponentPalettePrefix = 'TJv';
  RsNoJVCLFound = 'No JVCL directory found. Application terminated.';
  RsJVCLInstaller = 'JVCL Installer';

  RsCleaningPalette = 'Cleaning Palette...';
  RsCleaningPathLists = 'Cleaning Path lists...';
  RsUnregisteringPackages = 'Unregistering packages...';
  RsDeletingFiles = 'Deleting files...';
  RsComplete = 'Complete.';

function ReadRegString(RootKey: HKEY; const Key, Name: string): string;
var
  Reg: TRegistry;
begin
  Result := '';
  Reg := TRegistry.Create;
  try
    Reg.RootKey := RootKey;
    if Reg.OpenKeyReadOnly(Key) then
    begin
      if Reg.ValueExists(Name) then
        Result := Reg.ReadString(Name);
    end;
  finally
    Reg.Free;
  end;
end;

function FixBackslashBackslash(const Dir: string): string;
var
  ps: Integer;
begin
  Result := Dir;
  ps := Pos('\\', Result);
  if ps > 0 then
    Delete(Result, ps, 1);
end;

{ TJVCLData }

constructor TJVCLData.Create;
var
  I: Integer;
  ErrMsg: string;
begin
  inherited Create;
  FDeleteFilesOnUninstall := True;
  FCompileJclDcp := True;
  FVerbose := False;

  ErrMsg := '';
  LoadConfig(JVCLDir + '\' + sPackageGeneratorFile, 'JVCL', ErrMsg);

  FTargets := TCompileTargetList.Create;
  SetLength(FConfigs, Targets.Count);
  for I := 0 to High(FConfigs) do
    FConfigs[I] := TTargetConfig.Create(Self, Targets[I]);
  Init;
end;

destructor TJVCLData.Destroy;
var
  i: Integer;
begin
  for i := 0 to High(FConfigs) do
    FConfigs[I].Free;
  FTargets.Free;
  inherited Destroy;
end;

function TJVCLData.FindTargetConfig(const TargetSymbol: string): TTargetConfig;
var
  i: Integer;
begin
  for i := 0 to Targets.Count - 1 do
  begin
    Result := TargetConfig[i];
    if CompareText(TargetSymbol, Result.TargetSymbol) = 0 then
      Exit;
  end;
  Result := nil;
end;

function TJVCLData.GetOptionState(Index: Integer): Integer;
var
  i: Integer;
  b: Boolean;
begin
  Result := 0; // false
  for i := 0 to Targets.Count - 1 do
  begin
    if TargetConfig[i].InstallJVCL then
    begin
      case Index of
        0: b := TargetConfig[i].Build;
        1: b := TargetConfig[i].CleanPalettes;
        2: b := TargetConfig[i].CompileOnly;
        3: b := TargetConfig[i].DeveloperInstall;
        4: b := TargetConfig[i].DebugUnits;
        5: b := TargetConfig[i].GenerateMapFiles;
      else
        b := False;
      end;
      if b then
      begin
        if Result = 3 then
        begin
          Result := 2;
          Exit;
        end;
        Result := 1 // true
      end
      else
      begin
        if Result = 1 then
        begin
          Result := 2; // mixed
          Exit;
        end;
        Result := 3;
      end;
    end;
  end;
  if Result = 3 then
    Result := 0;
end;

function TJVCLData.GetBuild: Integer;
begin
  Result := GetOptionState(0);
end;

function TJVCLData.GetCleanPalettes: Integer;
begin
  Result := GetOptionState(1);
end;

function TJVCLData.GetCompileOnly: Integer;
begin
  Result := GetOptionState(2);
end;

function TJVCLData.GetDeveloperInstall: Integer;
begin
  Result := GetOptionState(3);
end;

function TJVCLData.GetDebugUnits: Integer;
begin
  Result := GetOptionState(4);
end;

function TJVCLData.GetGenerateMapFiles: Integer;
begin
  Result := GetOptionState(5);
end;

function TTargetConfig.GetJVCLConfig: TJVCLConfig;
begin
  Result := FJVCLConfig;
end;

function TJVCLData.GetJVCLDir: string;
begin
  if FJVCLDir = '' then
  begin
    FJVCLDir := ExtractFileDir(ParamStr(0));
    while not DirectoryExists(JVCLPackagesDir) do
    begin
      if Length(FJVCLDir) < 4 then
      begin
        MessageBox(0, PChar(RsNoJVCLFound), PChar(RsJVCLInstaller), MB_ICONERROR or MB_OK);
        Halt(1);
        Break;
      end;
      FJVCLDir := ExtractFileDir(JVCLDir);
    end;
  end;
  Result := FJVCLDir;
end;

function TJVCLData.GetJVCLPackagesDir: string;