Added: singleton App object

X2App.pas

@@ -39,8 +39,300 @@
 unit X2App;
 
 interface
+uses
+  Classes;
+
+type
+  {
+    :$ Stores version info strings
+
+    :! This class descends from TPersistent, allowing the use of RTTI to
+    :! retrieve version info names.
+  }
+  TX2AppVersionStrings  = class(TPersistent)
+  private
+    FValues:          TStringList;
+
+    function GetValue(const Index: Integer): String;
+    procedure SetValue(const Index: Integer; const Value: String);
+  public
+    constructor Create();
+    destructor Destroy(); override;
+  published
+    property CompanyName:       String index 0  read GetValue write SetValue;
+    property FileDescription:   String index 1  read GetValue write SetValue;
+    property FileVersion:       String index 2  read GetValue write SetValue;
+    property InternalName:      String index 3  read GetValue write SetValue;
+    property LegalCopyright:    String index 4  read GetValue write SetValue;
+    property LegalTrademark:    String index 5  read GetValue write SetValue;
+    property OriginalFilename:  String index 6  read GetValue write SetValue;
+    property ProductName:       String index 7  read GetValue write SetValue;
+    property ProductVersion:    String index 8  read GetValue write SetValue;
+    property Comments:          String index 9  read GetValue write SetValue;
+  end;
+
+  {
+    :$ Stores the application's version information
+  }
+  TX2AppVersion = class(TObject)
+  private
+    FMajor:           Integer;
+    FMinor:           Integer;
+    FRelease:         Integer;
+    FBuild:           Integer;
+    FStrings:         TX2AppVersionStrings;
+  public
+    constructor Create();
+    destructor Destroy(); override;
+
+    property Major:           Integer               read FMajor     write FMajor;
+    property Minor:           Integer               read FMinor     write FMinor;
+    property Release:         Integer               read FRelease   write FRelease;
+    property Build:           Integer               read FBuild     write FBuild;
+    property Strings:         TX2AppVersionStrings  read FStrings;
+  end;
+
+  TX2App  = class(TObject)
+  private
+    FVersion:         TX2AppVersion;
+    FPath:            String;
+  protected
+    function GetModule(): String; virtual;
+    procedure GetPath(); virtual;
+    procedure GetVersion(); virtual;
+  public
+    constructor Create();
+    destructor Destroy(); override;
+
+    function FormatVersion(Build: Boolean = True): String;
+
+    property Path:      String          read FPath;
+    property Version:   TX2AppVersion   read FVersion;
+  end;
+
+  function App(): TX2App;
 
 implementation
+uses
+  SysUtils,
+  TypInfo,
+  Windows;
+
+const
+  tkStrings = [tkString, tkLString, tkWString];
+
+var
+  GApp:       TX2App;
+  
+
+{========================================
+  Singleton
+========================================}
+function App;
+begin
+  if not Assigned(GApp) then
+    GApp  := TX2App.Create();
+
+  Result  := GApp;
+end;
+
+
+{=================== TX2AppVersionStrings
+  Initialization
+========================================}
+constructor TX2AppVersionStrings.Create;
+begin
+  inherited;
+
+  FValues := TStringList.Create();
+end;
+
+destructor TX2AppVersionStrings.Destroy;
+begin
+  FreeAndNil(FValues);
+
+  inherited;
+end;
+
+
+function TX2AppVersionStrings.GetValue;
+begin
+  if (Index > 0) and (Index < FValues.Count) then
+    Result  := FValues[Index]
+  else
+    Result  := '';
+end;
+
+procedure TX2AppVersionStrings.SetValue;
+var
+  iAdd:     Integer;
+
+begin
+  if Index >= FValues.Count then
+    for iAdd := FValues.Count to Index do
+      FValues.Add('');
+
+  FValues[Index]  := Value;
+end;
+
+
+{========================== TX2AppVersion
+  Initialization
+========================================}
+constructor TX2AppVersion.Create;
+begin
+  inherited;
+
+  FStrings  := TX2AppVersionStrings.Create();
+end;
+
+destructor TX2AppVersion.Destroy;
+begin
+  FreeAndNil(FStrings);
+
+  inherited;
+end;
+
+
+{================================= TX2App
+  Initialization
+========================================}
+constructor TX2App.Create;
+begin
+  inherited;
+
+  GetPath();
+  GetVersion();
+end;
+
+destructor TX2App.Destroy;
+begin
+  FreeAndNil(FVersion);
+
+  inherited;
+end;
+
+
+{================================= TX2App
+  Path
+========================================}
+function TX2App.GetModule;
+var
+  cModule:  array[0..MAX_PATH] of Char;
+
+begin
+  FillChar(cModule, SizeOf(cModule), #0);
+  GetModuleFileName(hInstance, @cModule, SizeOf(cModule));
+  Result  := String(cModule);
+end;
+
+
+procedure TX2App.GetPath;
+begin
+  FPath   := ExcludeTrailingPathDelimiter(ExtractFilePath(GetModule()));
+end;
+
+
+{================================= TX2App
+  Version
+========================================}
+function TX2App.FormatVersion;
+var
+  sBuild:     String;
+
+begin
+  sBuild    := '';
+
+  if Build then
+    sBuild    := Format(' build %d', [FVersion.Build]);
+
+  with FVersion do
+    Result := Format('v%d.%d.%d%s', [Major, Minor, Release, sBuild]);
+end;
+
+
+procedure TX2App.GetVersion;
+type
+  PLongInt  = ^LongInt;
+
+var
+  pInfo:    PVSFixedFileInfo;
+  dInfo:    Cardinal;
+  dSize:    Cardinal;
+  dVer:     Cardinal;
+  dTemp:    Cardinal;
+  pBuffer:  PChar;
+  pFile:    PChar;
+  iCount:   Integer;
+  iSize:    Integer;
+  iProp:    Integer;
+  pProps:   PPropList;
+  pCode:    PLongInt;
+  pValue:   PChar;
+  aCode:    array[0..1] of Word;
+  cName:    array[0..25] of Char;
+
+begin
+  with FVersion do begin
+    Major   := 0;
+    Minor   := 0;
+    Release := 0;
+    Build   := 0;
+  end;
+  
+  pFile := PChar(GetModule());
+  dSize := GetFileVersionInfoSize(pFile, dTemp);
+
+  if dSize <> 0 then begin
+    GetMem(pBuffer, dSize);
+
+    try
+      if GetFileVersionInfo(pFile, dTemp, dSize, pBuffer) then
+        // Get version numbers
+        with FVersion do begin
+          if VerQueryValue(pBuffer, '\', Pointer(pInfo), dInfo) then begin
+            Major   := HiWord(pInfo^.dwFileVersionMS);
+            Minor   := LoWord(pInfo^.dwFileVersionMS);
+            Release := HiWord(pInfo^.dwFileVersionLS);
+            Build   := LoWord(pInfo^.dwFileVersionLS);
+          end;
+
+          // Get additional version information using RTTI
+          VerQueryValue(pBuffer, '\VarFileInfo\Translation', Pointer(pCode), dVer);
+          if dVer <> 0 then begin
+            aCode[0]  := HiWord(pCode^);
+            aCode[1]  := LoWord(pCode^);
+            
+            FillChar(cName, SizeOf(cName), #0);
+            wvsprintf(cName, '\StringFileInfo\%8.8lx', @aCode);
+
+            iCount  := GetPropList(FVersion.Strings.ClassInfo, tkStrings, nil);
+            iSize   := iCount * SizeOf(TPropInfo);
+            GetMem(pProps, iSize);
+
+            try
+              GetPropList(FVersion.Strings.ClassInfo, tkStrings, pProps);
+
+              for iProp := 0 to iCount - 1 do begin
+                if VerQueryValue(pBuffer, PChar(cName + '\' + pProps^[iProp]^.Name),
+                                 Pointer(pValue), dVer) then
+                  SetStrProp(FVersion.Strings, pProps[iProp], pValue);
+              end;
+            finally
+              FreeMem(pProps, iSize);
+            end;
+          end;
+        end;
+    finally
+      FreeMem(pBuffer, dSize);
+    end;
+  end;
+end;
+
+
+initialization
+finalization
+  FreeAndNil(GApp);
 
 end.