mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-11-04 07:59:43 +01:00
861 lines
25 KiB
ObjectPascal
861 lines
25 KiB
ObjectPascal
{
|
|
/***************************************************************************
|
|
w32versioninfo.pas - Lazarus IDE unit
|
|
---------------------------------------
|
|
TVersionInfo is responsible for the inclusion of the
|
|
version information in windows executables.
|
|
|
|
|
|
Initial Revision : Sun Feb 20 12:00:00 CST 2006
|
|
|
|
|
|
***************************************************************************/
|
|
|
|
***************************************************************************
|
|
* *
|
|
* This source is free software; you can redistribute it and/or modify *
|
|
* it under the terms of the GNU General Public License as published by *
|
|
* the Free Software Foundation; either version 2 of the License, or *
|
|
* (at your option) any later version. *
|
|
* *
|
|
* This code is distributed in the hope that it will be useful, but *
|
|
* WITHOUT ANY WARRANTY; without even the implied warranty of *
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
|
|
* General Public License for more details. *
|
|
* *
|
|
* A copy of the GNU General Public License is available on the World *
|
|
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
|
|
* obtain it by writing to the Free Software Foundation, *
|
|
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
|
|
* *
|
|
***************************************************************************
|
|
}
|
|
unit W32VersionInfo;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
{$I ide.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, LCLProc, Controls, Forms, FileUtil, TypInfo, laz2_DOM,
|
|
Laz2_XMLCfg, CodeToolManager, LazConf, IDEProcs, ProjectIntf, CompOptsIntf,
|
|
ProjectResourcesIntf, resource, versionresource, versiontypes, versionconsts,
|
|
TransferMacros;
|
|
|
|
type
|
|
|
|
{ TProjectVersionStringTable }
|
|
|
|
TProjectVersionStringTable = class(TVersionStringTable)
|
|
private
|
|
FOnModified: TNotifyEvent;
|
|
function GetValues(const Key: string): string;
|
|
procedure SetValues(const Key: string; const AValue: string);
|
|
protected
|
|
procedure DoModified;
|
|
function KeyToIndex(const aKey: String): Integer;
|
|
public
|
|
constructor Create(const aName: string); reintroduce;
|
|
procedure Add(const aKey, aValue: string); reintroduce;
|
|
procedure AddDefault;
|
|
function Equals(aTable: TProjectVersionStringTable): boolean; reintroduce;
|
|
procedure Assign(aTable: TProjectVersionStringTable); virtual;
|
|
procedure AddRequired;
|
|
procedure Clear; reintroduce;
|
|
procedure Delete(const aIndex: integer); overload; reintroduce;
|
|
procedure Delete(const aKey: string); overload; reintroduce;
|
|
function IsRequired(const aKey: string): Boolean;
|
|
property Values[Key: string]: string read GetValues write SetValues; default;
|
|
property OnModified: TNotifyEvent read FOnModified write FOnModified;
|
|
end;
|
|
|
|
TProjectVersionAttribute = (
|
|
pvaDebug,
|
|
pvaPreRelease,
|
|
pvaPatched,
|
|
pvaPrivateBuild,
|
|
pvaSpecialBuild
|
|
);
|
|
TProjectVersionAttributes = set of TProjectVersionAttribute;
|
|
|
|
{ TProjectVersionInfo }
|
|
|
|
TProjectVersionInfo = class(TAbstractProjectResource)
|
|
private
|
|
FAttributes: TProjectVersionAttributes;
|
|
FAutoIncrementBuild: boolean;
|
|
FHexCharSet: string;
|
|
FHexLang: string;
|
|
FStringTable: TProjectVersionStringTable;
|
|
FUseVersionInfo: boolean;
|
|
FVersion: TFileProductVersion;
|
|
function GetCharSets: TStringList;
|
|
function GetHexCharSets: TStringList;
|
|
function GetHexLanguages: TStringList;
|
|
function GetLanguages: TStringList;
|
|
function GetVersion(AIndex: integer): integer;
|
|
procedure SetAttributes(AValue: TProjectVersionAttributes);
|
|
procedure SetAutoIncrementBuild(const AValue: boolean);
|
|
procedure SetFileVersionFromVersion;
|
|
procedure SetHexCharSet(const AValue: string);
|
|
procedure SetHexLang(const AValue: string);
|
|
procedure SetUseVersionInfo(const AValue: boolean);
|
|
procedure SetVersion(AIndex: integer; const AValue: integer);
|
|
function ExtractProductVersion: TFileProductVersion;
|
|
function GetFileFlags: LongWord;
|
|
function BuildFileVersionString: String;
|
|
procedure DoModified(Sender: TObject);
|
|
public
|
|
constructor Create; override;
|
|
destructor Destroy; override;
|
|
|
|
procedure DoAfterBuild({%H-}AResources: TAbstractProjectResources;
|
|
AReason: TCompileReason; {%H-}SaveToTestDir: boolean); override;
|
|
function UpdateResources(AResources: TAbstractProjectResources;
|
|
const {%H-}MainFilename: string): boolean; override;
|
|
procedure WriteToProjectFile(AConfig: {TXMLConfig}TObject; const Path: string); override;
|
|
procedure ReadFromProjectFile(AConfig: {TXMLConfig}TObject; const Path: string); override;
|
|
|
|
property UseVersionInfo: boolean read FUseVersionInfo write SetUseVersionInfo;
|
|
property AutoIncrementBuild: boolean read FAutoIncrementBuild write SetAutoIncrementBuild;
|
|
|
|
property MajorVersionNr: integer index 0 read GetVersion write SetVersion;
|
|
property MinorVersionNr: integer index 1 read GetVersion write SetVersion;
|
|
property RevisionNr: integer index 2 read GetVersion write SetVersion;
|
|
property BuildNr: integer index 3 read GetVersion write SetVersion;
|
|
|
|
property Attributes: TProjectVersionAttributes read FAttributes write SetAttributes;
|
|
property HexLang: string read FHexLang write SetHexLang;
|
|
property HexCharSet: string read FHexCharSet write SetHexCharSet;
|
|
|
|
// string info
|
|
property StringTable: TProjectVersionStringTable read FStringTable;
|
|
end;
|
|
|
|
function MSLanguageToHex(const s: string): string;
|
|
function MSHexToLanguage(const s: string): string;
|
|
function MSCharacterSetToHex(const s: string): string;
|
|
function MSHexToCharacterSet(const s: string): string;
|
|
|
|
function MSLanguages: TStringList;
|
|
function MSHexLanguages: TStringList;
|
|
function MSCharacterSets: TStringList;
|
|
function MSHexCharacterSets: TStringList;
|
|
|
|
const
|
|
DefaultLanguage = '0409'; // U.S. English
|
|
DefaultCharSet = '04E4'; // Multilingual
|
|
|
|
ProjectVersionAttributeToStr: array[TProjectVersionAttribute] of String = (
|
|
{ pvaDebug } 'Debug',
|
|
{ pvaPreRelease } 'Pre-release',
|
|
{ pvaPatched } 'Patched',
|
|
{ pvaPrivateBuild } 'Private build',
|
|
{ pvaSpecialBuild } 'Special build'
|
|
);
|
|
|
|
implementation
|
|
|
|
var
|
|
// languages
|
|
fLanguages: TStringList = nil;
|
|
fHexLanguages: TStringList = nil;
|
|
|
|
// character sets
|
|
fCharSets: TStringList = nil;
|
|
fHexCharSets: TStringList = nil;
|
|
|
|
procedure CreateCharSets;
|
|
begin
|
|
if fCharSets <> nil then
|
|
exit;
|
|
fCharSets := TStringList.Create;
|
|
fHexCharSets := TStringList.Create;
|
|
|
|
fCharSets.Add('7-bit ASCII');
|
|
fHexCharSets.Add('0000');
|
|
fCharSets.Add('Japan (Shift - JIS X-0208)');
|
|
fHexCharSets.Add('03A4');
|
|
fCharSets.Add('Korea (Shift - KSC 5601)');
|
|
fHexCharSets.Add('03B5');
|
|
fCharSets.Add('Taiwan (Big5)');
|
|
fHexCharSets.Add('03B6');
|
|
fCharSets.Add('Unicode');
|
|
fHexCharSets.Add('04B0');
|
|
fCharSets.Add('Latin-2 (Eastern European)');
|
|
fHexCharSets.Add('04E2');
|
|
fCharSets.Add('Cyrillic');
|
|
fHexCharSets.Add('04E3');
|
|
fCharSets.Add('Multilingual');
|
|
fHexCharSets.Add('04E4');
|
|
fCharSets.Add('Greek');
|
|
fHexCharSets.Add('04E5');
|
|
fCharSets.Add('Turkish');
|
|
fHexCharSets.Add('04E6');
|
|
fCharSets.Add('Hebrew');
|
|
fHexCharSets.Add('04E7');
|
|
fCharSets.Add('Arabic');
|
|
fHexCharSets.Add('04E8');
|
|
end;
|
|
|
|
procedure CreateLanguages;
|
|
begin
|
|
if fLanguages <> nil then
|
|
exit;
|
|
fLanguages := TStringList.Create;
|
|
fHexLanguages := TStringList.Create;
|
|
fLanguages.Add('Arabic - Saudi Arabia');
|
|
fHexLanguages.Add('0401');
|
|
fLanguages.Add('Bulgarian');
|
|
fHexLanguages.Add('0402');
|
|
fLanguages.Add('Catalan');
|
|
fHexLanguages.Add('0403');
|
|
fLanguages.Add('Chinese - Taiwan');
|
|
fHexLanguages.Add('0404');
|
|
fLanguages.Add('Czech');
|
|
fHexLanguages.Add('0405');
|
|
fLanguages.Add('Danish');
|
|
fHexLanguages.Add('0406');
|
|
fLanguages.Add('German - Germany');
|
|
fHexLanguages.Add('0407');
|
|
fLanguages.Add('Greek');
|
|
fHexLanguages.Add('0408');
|
|
fLanguages.Add('English - United States');
|
|
fHexLanguages.Add('0409');
|
|
fLanguages.Add('Spanish - Spain (Traditional)');
|
|
fHexLanguages.Add('040A');
|
|
fLanguages.Add('Finnish');
|
|
fHexLanguages.Add('040B');
|
|
fLanguages.Add('French - France');
|
|
fHexLanguages.Add('040C');
|
|
fLanguages.Add('Hebrew');
|
|
fHexLanguages.Add('040D');
|
|
fLanguages.Add('Hungarian');
|
|
fHexLanguages.Add('040E');
|
|
fLanguages.Add('Icelandic');
|
|
fHexLanguages.Add('040F');
|
|
fLanguages.Add('Italian - Italy');
|
|
fHexLanguages.Add('0410');
|
|
fLanguages.Add('Japanese');
|
|
fHexLanguages.Add('0411');
|
|
fLanguages.Add('Korean');
|
|
fHexLanguages.Add('0412');
|
|
fLanguages.Add('Dutch - Netherlands');
|
|
fHexLanguages.Add('0413');
|
|
fLanguages.Add('Norwegian - Bokmal');
|
|
fHexLanguages.Add('0414');
|
|
fLanguages.Add('Italian - Switzerland');
|
|
fHexLanguages.Add('0810');
|
|
fLanguages.Add('Dutch - Belgium');
|
|
fHexLanguages.Add('0813');
|
|
fLanguages.Add('Norwegian - Nynorsk');
|
|
fHexLanguages.Add('0814');
|
|
fLanguages.Add('Polish');
|
|
fHexLanguages.Add('0415');
|
|
fLanguages.Add('Portuguese - Brazil');
|
|
fHexLanguages.Add('0416');
|
|
fLanguages.Add('Rhaeto-Romanic');
|
|
fHexLanguages.Add('0417');
|
|
fLanguages.Add('Romanian');
|
|
fHexLanguages.Add('0418');
|
|
fLanguages.Add('Russian');
|
|
fHexLanguages.Add('0419');
|
|
fLanguages.Add('Croatian');
|
|
fHexLanguages.Add('041A');
|
|
fLanguages.Add('Slovak');
|
|
fHexLanguages.Add('041B');
|
|
fLanguages.Add('Albanian');
|
|
fHexLanguages.Add('041C');
|
|
fLanguages.Add('Swedish');
|
|
fHexLanguages.Add('041D');
|
|
fLanguages.Add('Thai');
|
|
fHexLanguages.Add('041E');
|
|
fLanguages.Add('Turkish');
|
|
fHexLanguages.Add('041F');
|
|
fLanguages.Add('Urdu');
|
|
fHexLanguages.Add('0420');
|
|
fLanguages.Add('Indonesian');
|
|
fHexLanguages.Add('0421');
|
|
fLanguages.Add('Ukrainian');
|
|
fHexLanguages.Add('0422');
|
|
fLanguages.Add('Slovenian');
|
|
fHexLanguages.Add('0424');
|
|
fLanguages.Add('Lithuanian');
|
|
fHexLanguages.Add('0427');
|
|
fLanguages.Add('Chinese - People''s Republic of China');
|
|
fHexLanguages.Add('0804');
|
|
fLanguages.Add('German - Switzerland');
|
|
fHexLanguages.Add('0807');
|
|
fLanguages.Add('English - United Kingdom');
|
|
fHexLanguages.Add('0809');
|
|
fLanguages.Add('Spanish - Mexico');
|
|
fHexLanguages.Add('080A');
|
|
fLanguages.Add('French - Belgium');
|
|
fHexLanguages.Add('080C');
|
|
fLanguages.Add('French - Canada');
|
|
fHexLanguages.Add('0C0C');
|
|
fLanguages.Add('French - Switzerland');
|
|
fHexLanguages.Add('100C');
|
|
fLanguages.Add('Portuguese - Portugal');
|
|
fHexLanguages.Add('0816');
|
|
fLanguages.Add('Serbian (Cyrillic)');
|
|
fHexLanguages.Add('0C1A');
|
|
fLanguages.Add('Serbian (Latin)');
|
|
fHexLanguages.Add('081A');
|
|
end;
|
|
|
|
function MSLanguageToHex(const s: string): string;
|
|
var
|
|
i: longint;
|
|
begin
|
|
i := MSLanguages.IndexOf(s);
|
|
if i >= 0 then
|
|
Result := fHexLanguages[i]
|
|
else
|
|
Result := '';
|
|
end;
|
|
|
|
function MSHexToLanguage(const s: string): string;
|
|
var
|
|
i: longint;
|
|
begin
|
|
i := MSHexLanguages.IndexOf(s);
|
|
if i >= 0 then
|
|
Result := fLanguages[i]
|
|
else
|
|
Result := '';
|
|
end;
|
|
|
|
function MSCharacterSetToHex(const s: string): string;
|
|
var
|
|
i: longint;
|
|
begin
|
|
i := MSCharacterSets.IndexOf(s);
|
|
if i >= 0 then
|
|
Result := fHexCharSets[i]
|
|
else
|
|
Result := '';
|
|
end;
|
|
|
|
function MSHexToCharacterSet(const s: string): string;
|
|
var
|
|
i: longint;
|
|
begin
|
|
i := MSHexCharacterSets.IndexOf(s);
|
|
if i >= 0 then
|
|
Result := fCharSets[i]
|
|
else
|
|
Result := '';
|
|
end;
|
|
|
|
function MSLanguages: TStringList;
|
|
begin
|
|
CreateLanguages;
|
|
Result := fLanguages;
|
|
end;
|
|
|
|
function MSHexLanguages: TStringList;
|
|
begin
|
|
CreateLanguages;
|
|
Result := fHexLanguages;
|
|
end;
|
|
|
|
function MSCharacterSets: TStringList;
|
|
begin
|
|
CreateCharSets;
|
|
Result := fCharSets;
|
|
end;
|
|
|
|
function MSHexCharacterSets: TStringList;
|
|
begin
|
|
CreateCharSets;
|
|
Result := fHexCharSets;
|
|
end;
|
|
|
|
{ VersionInfo }
|
|
|
|
function TProjectVersionInfo.UpdateResources(AResources: TAbstractProjectResources;
|
|
const MainFilename: string): boolean;
|
|
var
|
|
ARes: TVersionResource;
|
|
st: TVersionStringTable;
|
|
ti: TVerTranslationInfo;
|
|
lang: string;
|
|
charset: string;
|
|
i: integer;
|
|
VersionValue : String;
|
|
begin
|
|
Result := True;
|
|
if UseVersionInfo then
|
|
begin
|
|
// project indicates to use the versioninfo
|
|
ARes := TVersionResource.Create(nil, nil);
|
|
//it's always RT_VERSION and 1 respectively
|
|
ARes.FixedInfo.FileVersion := FVersion;
|
|
ARes.FixedInfo.ProductVersion := ExtractProductVersion;
|
|
ARes.FixedInfo.FileFlags := GetFileFlags;
|
|
|
|
lang := HexLang;
|
|
if lang = '' then
|
|
lang := DefaultLanguage;
|
|
charset := HexCharSet;
|
|
if charset = '' then
|
|
charset := DefaultCharSet;
|
|
|
|
SetFileVersionFromVersion;
|
|
|
|
st := TVersionStringTable.Create(lang + charset);
|
|
for i := 0 to FStringTable.Count - 1 do
|
|
begin
|
|
VersionValue := FStringTable.ValuesByIndex[i];
|
|
GlobalMacroList.SubstituteStr(VersionValue);
|
|
st.Add(Utf8ToAnsi(FStringTable.Keys[i]), Utf8ToAnsi(VersionValue));
|
|
end;
|
|
ARes.StringFileInfo.Add(st);
|
|
|
|
ti.language := StrToInt('$' + lang);
|
|
ti.codepage := StrToInt('$' + charset);
|
|
ARes.VarFileInfo.Add(ti);
|
|
AResources.AddSystemResource(ARes);
|
|
end;
|
|
end;
|
|
|
|
procedure TProjectVersionInfo.WriteToProjectFile(AConfig: TObject;
|
|
const Path: string);
|
|
var
|
|
i: integer;
|
|
Key: string;
|
|
DefaultValue: String;
|
|
attr: TProjectVersionAttribute;
|
|
begin
|
|
with TXMLConfig(AConfig) do
|
|
begin
|
|
SetDeleteValue(Path + 'VersionInfo/UseVersionInfo/Value', UseVersionInfo, False);
|
|
SetDeleteValue(Path + 'VersionInfo/AutoIncrementBuild/Value',
|
|
AutoIncrementBuild, False);
|
|
SetDeleteValue(Path + 'VersionInfo/MajorVersionNr/Value', MajorVersionNr, 0);
|
|
SetDeleteValue(Path + 'VersionInfo/MinorVersionNr/Value', MinorVersionNr, 0);
|
|
SetDeleteValue(Path + 'VersionInfo/RevisionNr/Value', RevisionNr, 0);
|
|
SetDeleteValue(Path + 'VersionInfo/BuildNr/Value', BuildNr, 0);
|
|
SetDeleteValue(Path + 'VersionInfo/Language/Value', HexLang, DefaultLanguage);
|
|
SetDeleteValue(Path + 'VersionInfo/CharSet/Value', HexCharSet, DefaultCharset);
|
|
|
|
// write attributes
|
|
DeletePath(Path + 'VersionInfo/Attributes');
|
|
for attr in Attributes do
|
|
SetDeleteValue(Path + 'VersionInfo/Attributes/' + GetEnumName(TypeInfo(attr), Ord(attr)), True, False);
|
|
|
|
// write string info
|
|
DeletePath(Path + 'VersionInfo/StringTable');
|
|
for i := 0 to StringTable.Count - 1 do begin
|
|
Key:=StringTable.Keys[i];
|
|
if Key='FileVersion' then continue; // FileVersion is created automatically
|
|
DefaultValue:='';
|
|
if (Key='ProductVersion') then
|
|
DefaultValue:=BuildFileVersionString;
|
|
SetDeleteValue(Path + 'VersionInfo/StringTable/' + StringTable.Keys[i],
|
|
StringTable.ValuesByIndex[i],DefaultValue);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TProjectVersionInfo.ReadFromProjectFile(AConfig: TObject;
|
|
const Path: string);
|
|
var
|
|
i: integer;
|
|
Node: TDomNode;
|
|
attrs: TProjectVersionAttributes;
|
|
begin
|
|
with TXMLConfig(AConfig) do
|
|
begin
|
|
UseVersionInfo := GetValue(Path + 'VersionInfo/UseVersionInfo/Value', False);
|
|
AutoIncrementBuild := GetValue(Path + 'VersionInfo/AutoIncrementBuild/Value', False);
|
|
|
|
MajorVersionNr := GetValue(Path + 'VersionInfo/CurrentVersionNr/Value',
|
|
GetValue(Path + 'VersionInfo/MajorVersionNr/Value', 0));
|
|
MinorVersionNr := GetValue(Path + 'VersionInfo/CurrentMajorRevNr/Value',
|
|
GetValue(Path + 'VersionInfo/MinorVersionNr/Value', 0));
|
|
RevisionNr := GetValue(Path + 'VersionInfo/CurrentMinorRevNr/Value',
|
|
GetValue(Path + 'VersionInfo/RevisionNr/Value', 0));
|
|
BuildNr := GetValue(Path + 'VersionInfo/CurrentBuildNr/Value',
|
|
GetValue(Path + 'VersionInfo/BuildNr/Value', 0));
|
|
|
|
HexLang := GetValue(Path + 'VersionInfo/Language/Value', DefaultLanguage);
|
|
HexCharSet := GetValue(Path + 'VersionInfo/CharSet/Value', DefaultCharset);
|
|
|
|
// read attributes
|
|
attrs := [];
|
|
Node := FindNode(Path + 'VersionInfo/Attributes', False);
|
|
if Assigned(Node) then
|
|
begin
|
|
for i := 0 to Node.Attributes.Length - 1 do
|
|
if StrToBoolDef(Node.Attributes[i].NodeValue, False) then
|
|
include(attrs, TProjectVersionAttribute(GetEnumValue(TypeInfo(TProjectVersionAttribute), Node.Attributes[i].NodeName)));
|
|
end;
|
|
Attributes := attrs;
|
|
|
|
|
|
// read string info
|
|
Node := FindNode(Path + 'VersionInfo/StringTable', False);
|
|
if Assigned(Node) then
|
|
begin
|
|
StringTable.Clear;
|
|
for i := 0 to Node.Attributes.Length - 1 do
|
|
StringTable[Node.Attributes[i].NodeName] := Node.Attributes[i].NodeValue;
|
|
StringTable.AddRequired;
|
|
end
|
|
else
|
|
begin
|
|
// read old info
|
|
StringTable['Comments'] := GetValue(Path + 'VersionInfo/Comments/Value', '');
|
|
StringTable['CompanyName'] := GetValue(Path + 'VersionInfo/CompanyName/Value', '');
|
|
StringTable['FileDescription'] := GetValue(Path + 'VersionInfo/FileDescription/Value', '');
|
|
StringTable['FileVersion'] := BuildFileVersionString;
|
|
StringTable['InternalName'] := GetValue(Path + 'VersionInfo/InternalName/Value', '');
|
|
StringTable['LegalCopyright'] := GetValue(Path + 'VersionInfo/LegalCopyright/Value', '');
|
|
StringTable['LegalTrademarks'] := GetValue(Path + 'VersionInfo/LegalTrademarks/Value', '');
|
|
StringTable['OriginalFilename'] := GetValue(Path + 'VersionInfo/OriginalFilename/Value', '');
|
|
StringTable['ProductName'] := GetValue(Path + 'VersionInfo/ProductName/Value', '');
|
|
StringTable['ProductVersion'] := GetValue(Path + 'VersionInfo/ProjectVersion/Value', BuildFileVersionString);
|
|
end;
|
|
|
|
SetFileVersionFromVersion;
|
|
end;
|
|
end;
|
|
|
|
function TProjectVersionInfo.GetCharSets: TStringList;
|
|
begin
|
|
CreateCharSets;
|
|
Result := fHexCharSets;
|
|
end;
|
|
|
|
function TProjectVersionInfo.GetHexCharSets: TStringList;
|
|
begin
|
|
CreateCharSets;
|
|
Result := fHexCharSets;
|
|
end;
|
|
|
|
function TProjectVersionInfo.GetHexLanguages: TStringList;
|
|
begin
|
|
CreateLanguages;
|
|
Result := fHexLanguages;
|
|
end;
|
|
|
|
function TProjectVersionInfo.GetLanguages: TStringList;
|
|
begin
|
|
CreateLanguages;
|
|
Result := fLanguages;
|
|
end;
|
|
|
|
function TProjectVersionInfo.GetVersion(AIndex: integer): integer;
|
|
begin
|
|
Result := FVersion[AIndex];
|
|
end;
|
|
|
|
procedure TProjectVersionInfo.SetAttributes(AValue: TProjectVersionAttributes);
|
|
begin
|
|
if FAttributes = AValue then
|
|
Exit;
|
|
FAttributes := AValue;
|
|
Modified := True;
|
|
end;
|
|
|
|
procedure TProjectVersionInfo.SetAutoIncrementBuild(const AValue: boolean);
|
|
begin
|
|
if FAutoIncrementBuild = AValue then
|
|
exit;
|
|
FAutoIncrementBuild := AValue;
|
|
Modified := True;
|
|
end;
|
|
|
|
procedure TProjectVersionInfo.SetFileVersionFromVersion;
|
|
begin
|
|
FStringTable['FileVersion'] := BuildFileVersionString;
|
|
end;
|
|
|
|
procedure TProjectVersionInfo.SetHexCharSet(const AValue: string);
|
|
begin
|
|
if FHexCharSet = AValue then
|
|
exit;
|
|
FHexCharSet := AValue;
|
|
Modified := True;
|
|
end;
|
|
|
|
procedure TProjectVersionInfo.SetHexLang(const AValue: string);
|
|
begin
|
|
if FHexLang = AValue then
|
|
exit;
|
|
FHexLang := AValue;
|
|
Modified := True;
|
|
end;
|
|
|
|
procedure TProjectVersionInfo.SetUseVersionInfo(const AValue: boolean);
|
|
begin
|
|
if FUseVersionInfo = AValue then
|
|
exit;
|
|
FUseVersionInfo := AValue;
|
|
Modified := True;
|
|
end;
|
|
|
|
procedure TProjectVersionInfo.SetVersion(AIndex: integer; const AValue: integer);
|
|
begin
|
|
if FVersion[AIndex] = AValue then
|
|
Exit;
|
|
FVersion[AIndex] := AValue;
|
|
Modified := True;
|
|
end;
|
|
|
|
function TProjectVersionInfo.ExtractProductVersion: TFileProductVersion;
|
|
var
|
|
S, Part: string;
|
|
i, p: integer;
|
|
begin
|
|
S := StringTable['ProductVersion'];
|
|
for i := 0 to 3 do
|
|
begin
|
|
p := Pos('.', S);
|
|
if p >= 1 then
|
|
begin
|
|
Part := Copy(S, 1, p - 1);
|
|
Delete(S, 1, P);
|
|
end
|
|
else
|
|
begin
|
|
Part := S;
|
|
S := '';
|
|
end;
|
|
Result[i] := StrToIntDef(Part, 0);
|
|
end;
|
|
end;
|
|
|
|
function TProjectVersionInfo.GetFileFlags: LongWord;
|
|
const
|
|
AttributeToFileFlags: array[TProjectVersionAttribute] of LongWord = (
|
|
{ pvaDebug } VS_FF_DEBUG,
|
|
{ pvaPreRelease } VS_FF_PRERELEASE,
|
|
{ pvaPatched } VS_FF_PATCHED,
|
|
{ pvaPrivateBuild } VS_FF_PRIVATEBUILD,
|
|
{ pvaSpecialBuild } VS_FF_SPECIALBUILD
|
|
);
|
|
|
|
var
|
|
Attribute: TProjectVersionAttribute;
|
|
begin
|
|
Result := 0;
|
|
for Attribute in Attributes do
|
|
Result := Result or AttributeToFileFlags[Attribute];
|
|
end;
|
|
|
|
function TProjectVersionInfo.BuildFileVersionString: String;
|
|
begin
|
|
Result := Format('%d.%d.%d.%d', [MajorVersionNr, MinorVersionNr, RevisionNr, BuildNr]);
|
|
end;
|
|
|
|
procedure TProjectVersionInfo.DoModified(Sender: TObject);
|
|
begin
|
|
Modified := True;
|
|
end;
|
|
|
|
constructor TProjectVersionInfo.Create;
|
|
begin
|
|
inherited Create;
|
|
FAttributes := [];
|
|
FStringTable := TProjectVersionStringTable.Create('00000000');
|
|
FStringTable.OnModified := @DoModified;
|
|
HexLang:=DefaultLanguage;
|
|
HexCharSet:=DefaultCharSet;
|
|
end;
|
|
|
|
destructor TProjectVersionInfo.Destroy;
|
|
begin
|
|
FStringTable.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TProjectVersionInfo.DoAfterBuild(AResources: TAbstractProjectResources;
|
|
AReason: TCompileReason; SaveToTestDir: boolean);
|
|
begin
|
|
if (AReason = crBuild) and AutoIncrementBuild then // project indicate to use autoincrementbuild
|
|
BuildNr := BuildNr + 1;
|
|
end;
|
|
|
|
{ TProjectVersionStringTable }
|
|
|
|
function TProjectVersionStringTable.GetValues(const Key: string): string;
|
|
var
|
|
idx: Integer;
|
|
begin
|
|
idx := KeyToIndex(Key);
|
|
if idx = -1 then
|
|
Result := ''
|
|
else
|
|
Result := ValuesByIndex[idx];
|
|
end;
|
|
|
|
procedure TProjectVersionStringTable.SetValues(const Key: string;
|
|
const AValue: string);
|
|
var
|
|
idx: Integer;
|
|
begin
|
|
idx := KeyToIndex(Key);
|
|
if idx = -1 then
|
|
Add(Key, AValue)
|
|
else if ValuesByIndex[idx] = AValue then
|
|
exit
|
|
else
|
|
ValuesByIndex[idx] := AValue;
|
|
DoModified;
|
|
end;
|
|
|
|
procedure TProjectVersionStringTable.AddDefault;
|
|
begin
|
|
Add('Comments', '');
|
|
Add('CompanyName', '');
|
|
Add('FileDescription', '');
|
|
Add('FileVersion', '');
|
|
Add('InternalName', '');
|
|
Add('LegalCopyright', '');
|
|
Add('LegalTrademarks', '');
|
|
Add('OriginalFilename', '');
|
|
// - PrivateBuild
|
|
Add('ProductName', '');
|
|
Add('ProductVersion', '');
|
|
// - SpecialBuild
|
|
end;
|
|
|
|
function TProjectVersionStringTable.Equals(aTable: TProjectVersionStringTable): boolean;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result:=true;
|
|
for i:=0 to Count-1 do begin
|
|
if aTable.Values[Keys[i]]<>ValuesByIndex[i] then begin
|
|
debugln(['TProjectVersionStringTable.Equals differ Key=',Keys[i],' my=',ValuesByIndex[i],' other=',aTable.Values[Keys[i]]]);
|
|
Result:=false;
|
|
end;
|
|
end;
|
|
for i:=0 to aTable.Count-1 do begin
|
|
if Values[aTable.Keys[i]]<>aTable.ValuesByIndex[i] then begin
|
|
debugln(['TProjectVersionStringTable.Equals differ Key=',aTable.Keys[i],' my=',Values[aTable.Keys[i]],' other=',aTable.ValuesByIndex[i]]);
|
|
Result:=false;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TProjectVersionStringTable.Assign(aTable: TProjectVersionStringTable);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
if Equals(aTable) then exit;
|
|
Clear;
|
|
for i := 0 to aTable.Count - 1 do
|
|
inherited Add(aTable.Keys[i],aTable.ValuesByIndex[i]);
|
|
DoModified;
|
|
end;
|
|
|
|
function TProjectVersionStringTable.KeyToIndex(const aKey: String): Integer;
|
|
var
|
|
i : integer;
|
|
begin
|
|
for i := 0 to Count - 1 do
|
|
if Keys[i] = aKey then
|
|
exit(i);
|
|
Result := -1;
|
|
end;
|
|
|
|
procedure TProjectVersionStringTable.DoModified;
|
|
begin
|
|
if Assigned(OnModified) then
|
|
OnModified(Self);
|
|
end;
|
|
|
|
constructor TProjectVersionStringTable.Create(const aName: string);
|
|
begin
|
|
inherited Create(aName);
|
|
AddDefault;
|
|
end;
|
|
|
|
procedure TProjectVersionStringTable.Add(const aKey, aValue: string);
|
|
begin
|
|
inherited Add(aKey, aValue);
|
|
DoModified;
|
|
end;
|
|
|
|
procedure TProjectVersionStringTable.AddRequired;
|
|
const
|
|
RequiredFields: array[0..9] of String = (
|
|
'Comments',
|
|
'CompanyName',
|
|
'FileDescription',
|
|
'FileVersion',
|
|
'InternalName',
|
|
'LegalCopyright',
|
|
'LegalTrademarks',
|
|
'OriginalFilename',
|
|
'ProductName',
|
|
'ProductVersion'
|
|
);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := Low(RequiredFields) to High(RequiredFields) do
|
|
if KeyToIndex(RequiredFields[i]) = -1 then
|
|
Add(RequiredFields[i], '');
|
|
end;
|
|
|
|
procedure TProjectVersionStringTable.Clear;
|
|
begin
|
|
if Count > 0 then
|
|
begin
|
|
inherited Clear;
|
|
DoModified;
|
|
end;
|
|
end;
|
|
|
|
procedure TProjectVersionStringTable.Delete(const aIndex: integer);
|
|
begin
|
|
if not IsRequired(Keys[aIndex]) then
|
|
begin
|
|
inherited Delete(aIndex);
|
|
DoModified;
|
|
end;
|
|
end;
|
|
|
|
procedure TProjectVersionStringTable.Delete(const aKey: string);
|
|
begin
|
|
if not IsRequired(aKey) then
|
|
begin
|
|
inherited Delete(aKey);
|
|
DoModified;
|
|
end;
|
|
end;
|
|
|
|
function TProjectVersionStringTable.IsRequired(const aKey: string): Boolean;
|
|
begin
|
|
Result :=
|
|
(aKey = 'Comments') or
|
|
(aKey = 'CompanyName') or
|
|
(aKey = 'FileDescription') or
|
|
(aKey = 'FileVersion') or
|
|
(aKey = 'InternalName') or
|
|
(aKey = 'LegalCopyright') or
|
|
(aKey = 'LegalTrademarks') or
|
|
(aKey = 'OriginalFilename') or
|
|
(aKey = 'ProductName') or
|
|
(aKey = 'ProductVersion');
|
|
end;
|
|
|
|
initialization
|
|
RegisterProjectResource(TProjectVersionInfo);
|
|
|
|
finalization
|
|
FreeAndNil(fHexCharSets);
|
|
FreeAndNil(fHexLanguages);
|
|
FreeAndNil(fLanguages);
|
|
FreeAndNil(fCharSets);
|
|
|
|
end.
|
|
|