babaev-an/lasarus_compotents
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Стартовый пул

Browse Source
This commit is contained in:
Александр Бабаев
2024-04-02 08:46:59 +03:00
parent fd57fffd3a
commit 3bb34d000b
5591 changed files with 3291734 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

59
bgrabitmap/dev/releaser/archiveurl.pas Normal file
View File

@@ -0,0 +1,59 @@
// SPDX-License-Identifier: LGPL-3.0-linking-exception
unit ArchiveUrl;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, ReleaserTypes;
type
{ TArchiveUrl }
TArchiveUrl = class(TReleaserObject)
private
FUrl: string;
public
constructor Create(AParameters: TStringList; ALogicDir: string); override;
class function IsUnique: boolean; override;
function GetUrlForVersion(AVersion: TVersion): string;
property Url: string read FUrl;
procedure GetVersions({%H-}AVersionList: TStringList); override;
procedure Save; override;
end;
implementation
{ TArchiveUrl }
constructor TArchiveUrl.Create(AParameters: TStringList; ALogicDir: string);
begin
inherited Create(AParameters, ALogicDir);
ExpectParamCount(1);
FUrl := Param[0];
end;
class function TArchiveUrl.IsUnique: boolean;
begin
Result:= true;
end;
function TArchiveUrl.GetUrlForVersion(AVersion: TVersion): string;
begin
result := ReplaceVariables(FUrl, AVersion);
end;
procedure TArchiveUrl.GetVersions(AVersionList: TStringList);
begin
//nothing
end;
procedure TArchiveUrl.Save;
begin
//nothing
end;
end.

10
bgrabitmap/dev/releaser/bgrabitmap.logic Normal file
View File

@@ -0,0 +1,10 @@
cd ..\..
manager update_BGRABitmap.json
archive https://github.com/bgrabitmap/bgrabitmap/archive/v$(Version).zip
cd bgrabitmap
package bgrabitmappack.lpk
package bgrabitmappack4fpgui.lpk
package bgrabitmappack4nogui.lpk
package bgrabitmappack4android.lpk
const bgrabitmaptypes.pas BGRABitmapVersion

174
bgrabitmap/dev/releaser/constfile.pas Normal file
View File

@@ -0,0 +1,174 @@
// SPDX-License-Identifier: LGPL-3.0-linking-exception
unit ConstFile;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, ReleaserTypes;
type
{ TConstFile }
TConstFile = class(TReleaserObject)
private
FFilename, FConstname: String;
FSourceCode: string;
FChanged: boolean;
procedure AnalyzeVersionLine(ALine: string; out AValueStart,
AValueLength: integer);
public
constructor Create(AParameters: TStringList; ALogicDir: string); override;
destructor Destroy; override;
procedure Save; override;
function TryVersion(out AValue: TVersion): boolean;
procedure GetVersions(AVersionList: TStringList); override;
procedure UpdateVersion(AVersion: TVersion); override;
end;
implementation
{ TConstFile }
procedure TConstFile.AnalyzeVersionLine(ALine: string; out AValueStart, AValueLength: integer);
var
s: String;
p: integer;
begin
AValueStart := 0;
AValueLength:= 0;
s := ALine;
p := pos(FConstname+' ',s);
if (p<> 0) and ((p=1) or (s[p-1] in[#0..#32])) then
begin
inc(p, length(FConstName));
while (p <= length(s)) and (s[p] in[#0..#32]) do inc(p);
if (p <= length(s)) and (s[p] = '=') then
begin
inc(p);
while (p <= length(s)) and (s[p] in[#0..#32]) do inc(p);
AValueStart := p;
while (p <= length(s)) and (s[p] in['0'..'9']) do inc(p);
AValueLength:= p-AValueStart;
exit;
end;
end;
end;
constructor TConstFile.Create(AParameters: TStringList; ALogicDir: string);
var
ver: TVersion;
str: TStringStream;
stream: TFileStream;
begin
inherited Create(AParameters, ALogicDir);
ExpectParamCount(2);
FFilename := ExpandFileName(ReplaceVariables(Param[0]));
FConstname := Param[1];
stream := nil;
str := nil;
try
stream := TFileStream.Create(FFilename, fmOpenRead);
str := TStringStream.Create('');
if str.CopyFrom(stream, stream.Size)<>stream.Size then
raise exception.Create('Unable to read file');
FSourceCode := str.DataString;
finally
str.Free;
stream.Free;
end;
if TryVersion(ver) then
writeln('Code file "',ExtractFileName(FFilename),'" version ',VersionToStr(ver))
else
writeln('Code file "',ExtractFileName(FFilename),'" undefined version');
end;
destructor TConstFile.Destroy;
begin
inherited Destroy;
end;
procedure TConstFile.Save;
var
stream: TFileStream;
begin
if FChanged then
begin
writeln('Updating code file "',ExtractFileName(FFilename),'"');
stream := TFileStream.Create(FFilename, fmCreate);
try
if FSourceCode <> '' then
stream.WriteBuffer(FSourceCode[1], length(FSourceCode));
finally
stream.Free;
end;
end;
end;
function TConstFile.TryVersion(out AValue: TVersion): boolean;
var
valueStart,valueLen,errPos: integer;
verValue: LongWord;
begin
AValue.Major:= 0;
AValue.Minor:= 0;
AValue.Release:= 0;
AValue.Build:= 0;
AnalyzeVersionLine(FSourceCode, valueStart, valueLen);
if valueStart > 0 then
begin
val(copy(FSourceCode, valueStart, valueLen), verValue, errPos);
if errPos = 0 then
begin
AValue.Major:= verValue div 1000000;
AValue.Minor := (verValue div 10000) mod 100;
AValue.Release := (verValue div 100) mod 100;
AValue.Build := verValue mod 100;
exit(true);
end;
end;
result := false;
end;
procedure TConstFile.GetVersions(AVersionList: TStringList);
var
ver: TVersion;
verStr: String;
begin
if TryVersion(ver) then
begin
verStr := VersionToStr(ver);
if AVersionList.IndexOf(verStr)=-1 then AVersionList.Add(verStr);
end;
end;
procedure TConstFile.UpdateVersion(AVersion: TVersion);
var
ver: TVersion;
newValue, valueStart, valueLength: Integer;
s: String;
begin
newValue := AVersion.Major*1000000 + AVersion.Minor*10000 + AVersion.Release*100 + AVersion.Build;
if TryVersion(ver) then
begin
if AVersion<>ver then
begin
AnalyzeVersionLine(FSourceCode, valueStart,valueLength);
if valueStart <> 0 then
begin
s := FSourceCode;
delete(s, valueStart,valueLength);
insert(IntToStr(newValue), s,valueStart);
FSourceCode := s;
FChanged:= true;
end;
end;
end else
writeln('Please add manually a constant ',FConstname,' = ',newValue,' in "',ExtractFileName(FFilename),'"');
end;
end.

83
bgrabitmap/dev/releaser/copyfile.pas Normal file
View File

@@ -0,0 +1,83 @@
// SPDX-License-Identifier: LGPL-3.0-linking-exception
unit CopyFile;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, ReleaserTypes;
type
{ TCopyFile }
TCopyFile = class(TReleaserObject)
private
FSourceFilename, FDestFilename: String;
FVersion: TVersion;
FVersionDefined: boolean;
public
constructor Create(AParameters: TStringList; ALogicDir: string); override;
procedure Save; override;
procedure GetVersions({%H-}AVersionList: TStringList); override;
procedure UpdateVersion(AVersion: TVersion); override;
end;
implementation
{ TCopyFile }
constructor TCopyFile.Create(AParameters: TStringList; ALogicDir: string);
begin
inherited Create(AParameters, ALogicDir);
ExpectParamCount(2);
FSourceFilename := ExpandFileName(Param[0]);
FDestFilename := ExpandFileName(Param[1]);
end;
procedure TCopyFile.Save;
var
dest: String;
streamIn,streamOut: TStream;
buf: array of byte;
bufCount: LongInt;
begin
if not FVersionDefined then exit;
streamIn := TFileStream.Create(ReplaceVariables(FSourceFilename), fmOpenRead);
streamOut := nil;
buf := nil;
try
dest := ReplaceVariables(FDestFilename);
if FileExists(dest) then
writeln('Replacing file "',ExtractFilename(dest),'"');
streamOut := TFileStream.Create(dest, fmCreate);
setlength(buf, 4096);
repeat
bufCount:= streamIn.Read(buf[0], length(buf));
streamOut.WriteBuffer(buf[0], bufCount);
until bufCount = 0;
finally
buf := nil;
streamOut.Free;
streamIn.Free;
end;
end;
procedure TCopyFile.GetVersions(AVersionList: TStringList);
begin
//nothing
end;
procedure TCopyFile.UpdateVersion(AVersion: TVersion);
begin
if not FileExists(ReplaceVariables(FSourceFilename)) then
raise exception.Create('Source file not found: '+FSourceFilename);
if not DirectoryExists(ExtractFilePath(ReplaceVariables(FDestFilename))) then
raise exception.Create('Target directory not found: '+ExtractFilePath(ReplaceVariables(FDestFilename)));
FVersion := AVersion;
FVersionDefined := true;
end;
end.

208
bgrabitmap/dev/releaser/macbundle.pas Normal file
View File

@@ -0,0 +1,208 @@
// SPDX-License-Identifier: LGPL-3.0-linking-exception
unit MacBundle;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, ReleaserTypes, laz2_XMLRead, laz2_XMLWrite, Laz2_DOM;
type
{ TMacBundle }
TMacBundle = class(TReleaserObject)
private
FBundlepath: string;
FFilename: string;
FXml: TXmlDocument;
FDict: TStringList;
FChanged: boolean;
function GetName: string;
function GetPListFilename: string;
function ReadDict(ARoot: TDOMNode): TStringList;
procedure UpdateDict(ARoot: TDOMNode; ADict: TStringList);
function GetPList: TDOMNode;
public
constructor Create(AParameters: TStringList; ALogicDir: string); override;
destructor Destroy; override;
property Filename: string read FFilename;
function GetVersion: TVersion;
procedure GetVersions(AVersionList: TStringList); override;
procedure CheckVersion(AVersion: TVersion); override;
property Name: string read GetName;
procedure Save; override;
procedure UpdateVersion(AVersion: TVersion); override;
end;
implementation
{ TMacBundle }
function TMacBundle.GetName: string;
begin
result := '';
if Assigned(FDict) then
result := FDict.Values['CFBundleName'];
if result = '' then
result := ChangeFileExt(ExtractFileName(FBundlepath),'');
end;
function TMacBundle.GetPListFilename: string;
begin
result := FBundlepath+PathDelim+'Contents'+PathDelim+'Info.plist';
end;
function TMacBundle.ReadDict(ARoot: TDOMNode): TStringList;
var
dict, entry: TDOMNode;
key: string;
begin
result := TStringList.Create;
if Assigned(ARoot) then
begin
dict := ARoot.FindNode('dict');
if Assigned(dict) then
begin
entry := dict.FirstChild;
while entry <> nil do
begin
if entry.NodeName = 'key' then
begin
key := entry.TextContent;
entry := entry.NextSibling;
if (entry <> nil) and (entry.NodeName = 'string') then
begin
result.Values[key] := entry.TextContent;
entry := entry.NextSibling;
end
else if (entry <> nil) and (entry.NodeName <> 'key') then
entry := entry.NextSibling;
end else
entry := entry.NextSibling;
end;
end else
raise exception.Create('"dict" node not found');
end;
end;
procedure TMacBundle.UpdateDict(ARoot: TDOMNode; ADict: TStringList);
var
dict, entry: TDOMNode;
key: string;
begin
if Assigned(ARoot) then
begin
dict := ARoot.FindNode('dict');
if Assigned(dict) then
begin
entry := dict.FirstChild;
while entry <> nil do
begin
if entry.NodeName = 'key' then
begin
key := entry.TextContent;
entry := entry.NextSibling;
if (entry <> nil) and (entry.NodeName = 'string') then
begin
entry.TextContent := ADict.Values[key];
entry := entry.NextSibling;
end
else if (entry <> nil) and (entry.NodeName <> 'key') then
entry := entry.NextSibling;
end else
entry := entry.NextSibling;
end;
end else
raise exception.Create('"dict" node not found');
end;
end;
function TMacBundle.GetPList: TDOMNode;
begin
result := FXml.FirstChild;
while (result <> nil) and not (result is TDOMElement) do result := result.NextSibling;
if (result = nil) or (result.NodeName <> 'plist') then raise exception.Create('"plist" node not found');
end;
constructor TMacBundle.Create(AParameters: TStringList; ALogicDir: string);
var
stream: TFileStream;
begin
inherited Create(AParameters, ALogicDir);
ExpectParamCount(1);
FBundlepath:= ExpandFileName(ReplaceVariables(Param[0]));
stream := TFileStream.Create(GetPListFilename, fmOpenRead);
try
ReadXMLFile(FXml,stream);
finally
stream.Free;
end;
FDict := ReadDict(GetPList);
writeln('Bundle ',Name,' version ',VersionToStr(GetVersion));
end;
destructor TMacBundle.Destroy;
begin
FXml.Free;
inherited Destroy;
end;
function TMacBundle.GetVersion: TVersion;
begin
if Assigned(FDict) then
result := StrToVersion(FDict.Values['CFBundleVersion'])
else raise exception.Create('Version node not found');
end;
procedure TMacBundle.GetVersions(AVersionList: TStringList);
var
ver: TVersion;
verStr: String;
begin
ver := GetVersion;
verStr := VersionToStr(ver);
if AVersionList.IndexOf(verStr)=-1 then
AVersionList.Add(verStr);
end;
procedure TMacBundle.CheckVersion(AVersion: TVersion);
begin
inherited CheckVersion(AVersion);
if AVersion<>GetVersion then raise exception.Create('Inconsistent version of bundle '+Name);
end;
procedure TMacBundle.Save;
begin
if FChanged then
begin
writeln('Updating bundle ', Name,'...');
WriteXMLFile(FXml, GetPListFilename);
end else
writeln('Bundle unchanged');
end;
procedure TMacBundle.UpdateVersion(AVersion: TVersion);
var
versionStr: String;
begin
if Assigned(FDict) then
begin
versionStr := VersionToStr(AVersion);
if FDict.Values['CFBundleVersion'] <> versionStr then
begin
FDict.Values['CFBundleVersion'] := versionStr;
FChanged := true;
end;
if FDict.Values['CFBundleShortVersionString'] <> versionStr then
begin
FDict.Values['CFBundleShortVersionString'] := versionStr;
FChanged := true;
end;
UpdateDict(GetPList, FDict);
end;
end;
end.

260
bgrabitmap/dev/releaser/managerfile.pas Normal file
View File

@@ -0,0 +1,260 @@
// SPDX-License-Identifier: LGPL-3.0-linking-exception
unit ManagerFile;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, ReleaserTypes,
fpjson, jsonparser, ArchiveUrl, PackageFile;
type
{ TManagerFile }
TManagerFile = class(TReleaserObject)
private
FArchive: TArchiveUrl;
FFilename: string;
FPackages: TPackageFileList;
FRoot: TJSONObject;
FNew, FChanged: boolean;
FLineEnding: string;
procedure SetArchive(AValue: TArchiveUrl);
function GetPackageUpdateList: TJSONArray;
function GetDataNode: TJSONObject;
function GetDownloadUrl: string;
public
constructor Create(AParameters: TStringList; ALogicDir: string); override;
destructor Destroy; override;
class function IsUnique: boolean; override;
procedure LinkWith(AOtherObject: TReleaserObject); override;
property Archive: TArchiveUrl read FArchive write SetArchive;
procedure GetVersions({%H-}AVersionList: TStringList); override;
procedure CheckVersion(AVersion: TVersion); override;
procedure UpdateVersion(AVersion: TVersion); override;
procedure Save; override;
end;
implementation
{ TManagerFile }
procedure TManagerFile.SetArchive(AValue: TArchiveUrl);
begin
if FArchive=AValue then Exit;
FArchive:=AValue;
end;
function TManagerFile.GetPackageUpdateList: TJSONArray;
const packagePath1 = 'UpdateLazPackages';
packagePath2 = 'UpdatePackageFiles';
var
node: TJSONData;
begin
node := FRoot.FindPath(packagePath1);
if node = nil then node := FRoot.FindPath(packagePath2);
if node <> nil then result := node as TJSONArray
else
begin
result := TJSONArray.Create;
FRoot.Add(packagePath1, result);
end;
end;
function TManagerFile.GetDataNode: TJSONObject;
const dataPath = 'UpdatePackageData';
var
node: TJSONData;
begin
node := FRoot.FindPath(dataPath);
if node <> nil then result := node as TJSONObject
else
begin
result := TJSONObject.Create;
FRoot.Add(dataPath, result);
end;
end;
function TManagerFile.GetDownloadUrl: string;
var
url: string;
data: TJSONObject;
begin
if Archive <> nil then
begin
data := GetDataNode;
url := '';
url := data.Get('DownloadZipURL', url);
result := url;
end
else result := '';
end;
constructor TManagerFile.Create(AParameters: TStringList; ALogicDir: string);
var
stream: TFileStream;
begin
inherited Create(AParameters, ALogicDir);
ExpectParamCount(1);
FFilename:= ExpandFileName(ReplaceVariables(Param[0]));
if FileExists(FFilename) then
begin
FLineEnding:= DetectLineEnding(FFilename);
FNew := false;
stream := TFileStream.Create(FFilename, fmOpenRead);
try
FRoot := GetJSON(stream) as TJSONObject;
finally
stream.Free;
end;
end else
begin
FNew := true;
FRoot := TJSONObject.Create;
end;
FPackages := TPackageFileList.Create;
end;
destructor TManagerFile.Destroy;
begin
FPackages.Free;
FRoot.Free;
inherited Destroy;
end;
class function TManagerFile.IsUnique: boolean;
begin
Result:= true;
end;
procedure TManagerFile.LinkWith(AOtherObject: TReleaserObject);
var
updateList: TJSONArray;
packageEntry: TJSONObject;
name: String;
i: Integer;
updateName: string;
package: TPackageFile;
updateVer: TVersion;
begin
inherited LinkWith(AOtherObject);
if AOtherObject is TArchiveUrl then
Archive := TArchiveUrl(AOtherObject)
else if AOtherObject is TPackageFile then
begin
package := TPackageFile(AOtherObject);
name := ExtractFileName(package.Filename);
updateList := GetPackageUpdateList;
if FNew then
begin
packageEntry := TJSONObject.Create;
packageEntry.Booleans['ForceNotify'] := false;
packageEntry.Integers['InternalVersion'] := 1;
packageEntry.Strings['Name'] := name;
packageEntry.Strings['Version'] := VersionToStr(package.GetVersion, true);
updateList.Add(packageEntry);
FPackages.Add(package);
end else
for i := 0 to updateList.Count-1 do
begin
packageEntry := updateList.Items[i] as TJSONObject;
updateName := packageEntry.Strings['Name'];
updateVer := StrToVersion(packageEntry.Strings['Version']);
if updateName = name then
begin
FPackages.Add(package);
writeln('Package ', package.name,' is used in manager');
if updateVer <> package.GetVersion then
raise exception.Create('Package version specified in manager is inconsistent');
end;
end;
end;
end;
procedure TManagerFile.GetVersions(AVersionList: TStringList);
begin
//version will be provided by packages
end;
procedure TManagerFile.CheckVersion(AVersion: TVersion);
var
url: string;
begin
inherited CheckVersion(AVersion);
if Archive <> nil then
begin
url := GetDownloadUrl;
if (url <> '') and (url <> Archive.GetUrlForVersion(AVersion)) then
raise exception.Create('Archive version is not consistent (DownloadZipURL field of JSON)');
end;
end;
procedure TManagerFile.UpdateVersion(AVersion: TVersion);
var
name, updateName, url: String;
i, j: Integer;
updateList: TJSONArray;
packageEntry, data: TJSONObject;
begin
for i := 0 to FPackages.Count-1 do
begin
name := ExtractFileName(FPackages[i].Filename);
updateList := GetPackageUpdateList;
for j := 0 to updateList.Count-1 do
begin
packageEntry := updateList.Items[j] as TJSONObject;
updateName := packageEntry.Strings['Name'];
if updateName = name then
begin
packageEntry.Strings['Version'] := VersionToStr(AVersion, true);
FChanged := true;
end;
end;
end;
data := GetDataNode;
url := Archive.GetUrlForVersion(AVersion);
data.Strings['DownloadZipURL'] := url;
end;
procedure TManagerFile.Save;
var t: textfile;
data: TJSONObject;
url: String;
begin
if (FPackages.Count = 0) then raise exception.Create('Manager does not have an associated package');
data := GetDataNode;
if FNew then
begin
data.Booleans['DisableInOPM'] := false;
data.Strings['Name'] := FPackages[0].Name;
end;
if Assigned(Archive) then
begin
if GetDownloadUrl = '' then
begin
url := Archive.GetUrlForVersion(FPackages[0].GetVersion);
data.Strings['DownloadZipURL'] := url;
FChanged := true;
end;
end;
if FNew or FChanged then
begin
if FNew then
writeln('Creating manager file...')
else
writeln('Updating manager file...');
assignfile(t, FFilename);
rewrite(t);
write(t, StringReplace(FRoot.FormatJSON, LineEnding, FLineEnding, [rfReplaceAll]));
closefile(t);
end else
writeln('Manager file unchanged');
end;
end.

177
bgrabitmap/dev/releaser/packagefile.pas Normal file
View File

@@ -0,0 +1,177 @@
// SPDX-License-Identifier: LGPL-3.0-linking-exception
unit PackageFile;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, ReleaserTypes, fgl, laz2_XMLRead, laz2_XMLWrite, Laz2_DOM;
type
{ TPackageFile }
TPackageFile = class(TReleaserObject)
private
FFilename: string;
FLineEnding: string;
FXml: TXmlDocument;
FChanged: boolean;
function GetName: string;
public
constructor Create(AParameters: TStringList; ALogicDir: string); override;
destructor Destroy; override;
property Filename: string read FFilename;
function GetVersion: TVersion;
procedure GetVersions(AVersionList: TStringList); override;
procedure CheckVersion(AVersion: TVersion); override;
property Name: string read GetName;
procedure Save; override;
procedure UpdateVersion(AVersion: TVersion); override;
end;
TPackageFileList = specialize TFPGList<TPackageFile>;
implementation
{ TPackageFile }
function TPackageFile.GetName: string;
var
config, packageNode, nameNode: TDOMNode;
begin
config := FXml.FindNode('CONFIG');
if Assigned(config) then
begin
packageNode := config.FindNode('Package');
if Assigned(packageNode) then
begin
nameNode := packageNode.FindNode('Name');
if Assigned(nameNode) then
begin
with (nameNode as TDOMElement) do
begin
result := GetAttribute('Value');
exit;
end;
end;
end;
end;
result := ChangeFileExt(ExtractFileName(FFilename),'');
end;
constructor TPackageFile.Create(AParameters: TStringList; ALogicDir: string);
var
stream: TFileStream;
begin
inherited Create(AParameters, ALogicDir);
ExpectParamCount(1);
FFilename:= ExpandFileName(ReplaceVariables(Param[0]));
FLineEnding:= DetectLineEnding(FFilename);
stream := TFileStream.Create(FFilename, fmOpenRead);
try
ReadXMLFile(FXml,stream);
finally
stream.Free;
end;
writeln('Package ',Name,' version ',VersionToStr(GetVersion));
end;
destructor TPackageFile.Destroy;
begin
FXml.Free;
inherited Destroy;
end;
function TPackageFile.GetVersion: TVersion;
var
config, packageNode, versionNode: TDOMNode;
begin
config := FXml.FindNode('CONFIG');
if Assigned(config) then
begin
packageNode := config.FindNode('Package');
if Assigned(packageNode) then
begin
versionNode := packageNode.FindNode('Version');
if Assigned(versionNode) then
begin
with (versionNode as TDOMElement) do
begin
result.Major:= StrToIntDef(GetAttribute('Major'),0);
result.Minor:= StrToIntDef(GetAttribute('Minor'),0);
result.Release:= StrToIntDef(GetAttribute('Release'),0);
result.Build:= StrToIntDef(GetAttribute('Build'),0);
exit;
end;
end;
end;
end;
raise exception.Create('Version node not found');
end;
procedure TPackageFile.GetVersions(AVersionList: TStringList);
var
ver: TVersion;
verStr: String;
begin
ver := GetVersion;
verStr := VersionToStr(ver);
if AVersionList.IndexOf(verStr)=-1 then
AVersionList.Add(verStr);
end;
procedure TPackageFile.CheckVersion(AVersion: TVersion);
begin
inherited CheckVersion(AVersion);
if AVersion<>GetVersion then raise exception.Create('Inconsistent version of package '+Name);
end;
procedure TPackageFile.Save;
var textStream: TStringStream;
t: TextFile;
begin
if FChanged then
begin
writeln('Updating package ', Name,'...');
textStream := TStringStream.Create;
WriteXMLFile(FXml, textStream);
AssignFile(t, FFilename);
Rewrite(t);
Write(t, StringReplace(textStream.DataString, LineEnding, FLineEnding, [rfReplaceAll]));
CloseFile(t);
textStream.Free;
end;
end;
procedure TPackageFile.UpdateVersion(AVersion: TVersion);
var
config, packageNode, versionNode: TDOMNode;
begin
config := FXml.FindNode('CONFIG');
if Assigned(config) then
begin
packageNode := config.FindNode('Package');
if Assigned(packageNode) then
begin
versionNode := packageNode.FindNode('Version');
if Assigned(versionNode) then
begin
with (versionNode as TDOMElement) do
begin
FChanged := true;
SetAttribute('Major', inttostr(AVersion.Major));
if AVersion.Minor <> 0 then SetAttribute('Minor', inttostr(AVersion.Minor)) else RemoveAttribute('Minor');
if AVersion.Release <> 0 then SetAttribute('Release', inttostr(AVersion.Release)) else RemoveAttribute('Release');
if AVersion.Build <> 0 then SetAttribute('Build', inttostr(AVersion.Build)) else RemoveAttribute('Build');
exit;
end;
end;
end;
end;
raise exception.Create('Version node not found');
end;
end.

200
bgrabitmap/dev/releaser/projectfile.pas Normal file
View File

@@ -0,0 +1,200 @@
// SPDX-License-Identifier: LGPL-3.0-linking-exception
unit ProjectFile;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, ReleaserTypes, laz2_XMLRead, laz2_XMLWrite, Laz2_DOM;
type
{ TProjectFile }
TProjectFile = class(TReleaserObject)
private
FFilename: string;
FXml: TXmlDocument;
FChanged: boolean;
function GetName: string;
public
constructor Create(AParameters: TStringList; ALogicDir: string); override;
destructor Destroy; override;
property Filename: string read FFilename;
function GetVersion: TVersion;
procedure GetVersions(AVersionList: TStringList); override;
procedure CheckVersion(AVersion: TVersion); override;
property Name: string read GetName;
procedure Save; override;
procedure UpdateVersion(AVersion: TVersion); override;
end;
implementation
{ TProjectFile }
function TProjectFile.GetName: string;
var
config, projectNode, titleNode, generalNode: TDOMNode;
begin
config := FXml.FindNode('CONFIG');
if Assigned(config) then
begin
projectNode := config.FindNode('ProjectOptions');
if Assigned(projectNode) then
begin
generalNode := projectNode.FindNode('General');
if Assigned(generalNode) then
begin
titleNode := generalNode.FindNode('Title');
if Assigned(titleNode) then
begin
with (titleNode as TDOMElement) do
begin
result := GetAttribute('Value');
exit;
end;
end;
end;
end;
end;
result := ChangeFileExt(ExtractFileName(FFilename),'');
end;
constructor TProjectFile.Create(AParameters: TStringList; ALogicDir: string);
var
stream: TFileStream;
begin
inherited Create(AParameters, ALogicDir);
ExpectParamCount(1);
FFilename:= ExpandFileName(ReplaceVariables(Param[0]));
stream := TFileStream.Create(FFilename, fmOpenRead);
try
ReadXMLFile(FXml,stream);
finally
stream.Free;
end;
writeln('Project ',Name,' version ',VersionToStr(GetVersion));
end;
destructor TProjectFile.Destroy;
begin
FXml.Free;
inherited Destroy;
end;
function TProjectFile.GetVersion: TVersion;
var
config, projectNode, versionNode: TDOMNode;
function GetSubNode(ATag: string): integer;
var
subNode: TDOMNode;
begin
subNode := versionNode.FindNode(ATag);
if Assigned(subNode) then with (subNode as TDOMElement) do
result:= StrToIntDef(GetAttribute('Value'),0)
else
result:= 0;
end;
begin
config := FXml.FindNode('CONFIG');
if Assigned(config) then
begin
projectNode := config.FindNode('ProjectOptions');
if Assigned(projectNode) then
begin
versionNode := projectNode.FindNode('VersionInfo');
if Assigned(versionNode) then
begin
result.Major:= GetSubNode('MajorVersionNr');
result.Minor:= GetSubNode('MinorVersionNr');
result.Release:= GetSubNode('RevisionNr');
result.Build:= GetSubNode('BuildNr');
exit;
end;
end;
end;
raise exception.Create('Version node not found');
end;
procedure TProjectFile.GetVersions(AVersionList: TStringList);
var
ver: TVersion;
verStr: String;
begin
ver := GetVersion;
verStr := VersionToStr(ver);
if AVersionList.IndexOf(verStr)=-1 then
AVersionList.Add(verStr);
end;
procedure TProjectFile.CheckVersion(AVersion: TVersion);
begin
inherited CheckVersion(AVersion);
if AVersion<>GetVersion then raise exception.Create('Inconsistent version of project '+Name);
end;
procedure TProjectFile.Save;
begin
if FChanged then
begin
writeln('Updating project ', Name,'...');
WriteXMLFile(FXml, FFilename);
end else
writeln('Project file unchanged');
end;
procedure TProjectFile.UpdateVersion(AVersion: TVersion);
var
config, projectNode, versionNode: TDOMNode;
procedure UpdateSubNode(ATag: string; AValue: integer);
var
subNode: TDOMElement;
begin
subNode := versionNode.FindNode(ATag) as TDOMElement;
if AValue<>0 then
begin
if subNode=nil then
begin
subNode := FXml.CreateElement(ATag);
versionNode.AppendChild(subNode);
end;
subNode.SetAttribute('Value', inttostr(AValue));
end else
begin
if Assigned(subNode) then
begin
versionNode.RemoveChild(subNode);
subNode.Free;
end;
end;
end;
begin
config := FXml.FindNode('CONFIG');
if Assigned(config) then
begin
projectNode := config.FindNode('ProjectOptions');
if Assigned(projectNode) then
begin
versionNode := projectNode.FindNode('VersionInfo');
if Assigned(versionNode) then
begin
FChanged := true;
UpdateSubNode('MajorVersionNr', AVersion.Major);
UpdateSubNode('MinorVersionNr', AVersion.Minor);
UpdateSubNode('RevisionNr', AVersion.Release);
UpdateSubNode('BuildNr', AVersion.Build);
exit;
end;
end;
end;
raise exception.Create('Version node not found');
end;
end.

116
bgrabitmap/dev/releaser/releaser.lpi Normal file
View File

@@ -0,0 +1,116 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasScaledStatement Value="False"/>
<CompatibilityMode Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<Title Value="Releaser"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="LazUtils"/>
</Item1>
</RequiredPackages>
<Units Count="11">
<Unit0>
<Filename Value="releaser.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="Releaser"/>
</Unit0>
<Unit1>
<Filename Value="bgrabitmap.logic"/>
<IsPartOfProject Value="True"/>
</Unit1>
<Unit2>
<Filename Value="releasertypes.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ReleaserTypes"/>
</Unit2>
<Unit3>
<Filename Value="managerfile.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ManagerFile"/>
</Unit3>
<Unit4>
<Filename Value="archiveurl.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ArchiveUrl"/>
</Unit4>
<Unit5>
<Filename Value="packagefile.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="PackageFile"/>
</Unit5>
<Unit6>
<Filename Value="constfile.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ConstFile"/>
</Unit6>
<Unit7>
<Filename Value="projectfile.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ProjectFile"/>
</Unit7>
<Unit8>
<Filename Value="textline.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="TextLine"/>
</Unit8>
<Unit9>
<Filename Value="copyfile.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="CopyFile"/>
</Unit9>
<Unit10>
<Filename Value="macbundle.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="MacBundle"/>
</Unit10>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="releaser"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf2Set"/>
</Debugging>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

325
bgrabitmap/dev/releaser/releaser.lpr Normal file
View File

@@ -0,0 +1,325 @@
// SPDX-License-Identifier: LGPL-3.0-only (modified to allow linking)
program Releaser;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Classes, SysUtils, CustApp, ReleaserTypes, ManagerFile, ArchiveUrl,
PackageFile, ProjectFile, ConstFile, TextLine, CopyFile, MacBundle
{ you can add units after this };
type
{ TReleaserApp }
TReleaserApp = class(TCustomApplication)
protected
procedure DoRun; override;
public
constructor Create(TheOwner: TComponent); override;
procedure ProcessFile(AFilename: string; AOptions: TStringList);
destructor Destroy; override;
procedure WriteHelp; virtual;
end;
TIfState = (isNone, isSkipTrue, isDoTrue, isSkipFalse, isDoFalse);
{ TReleaserApp }
procedure TReleaserApp.DoRun;
var
ErrorMsg, dir: String;
opts, logicFiles: TStringList;
i: Integer;
findRec: TRawByteSearchRec;
begin
// quick check parameters
opts := TStringList.Create;
logicFiles := TStringList.Create;
ErrorMsg:=CheckOptions('hv', ['help','version:'], opts, logicFiles);
if ErrorMsg<>'' then begin
writeln(ErrorMsg);
Terminate;
Exit;
end;
// parse parameters
if HasOption('h', 'help') then begin
WriteHelp;
Terminate;
Exit;
end;
if logicFiles.Count = 0 then
begin
if FindFirst('*.logic', faAnyFile, findRec)=0 then
repeat
if (findRec.Attr and faDirectory)=0 then logicFiles.Add(ExpandFileName(findRec.Name));
until FindNext(findRec)<>0;
FindClose(findRec);
end;
dir := GetCurrentDir;
for i := 0 to logicFiles.Count-1 do
begin
SetCurrentDir(dir);
ProcessFile(logicFiles[i], opts);
end;
opts.Free;
logicFiles.Free;
// stop program loop
Terminate;
end;
constructor TReleaserApp.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
StopOnException:=True;
end;
procedure TReleaserApp.ProcessFile(AFilename: string;
AOptions: TStringList);
var
objs: TReleaserObjectList;
function GetVersion: TVersion;
var versions: TStringList;
i: integer;
begin
versions := TStringList.Create;
try
for i := 0 to objs.Count-1 do
objs[i].GetVersions(versions);
if versions.Count = 0 then raise exception.Create('Version not found')
else if versions.Count > 1 then writeln('Multiple versions found!');
result := StrToVersion(versions[0]);
finally
versions.Free;
end;
end;
var
t: textfile;
s, cmd: string;
ver, newVer: TVersion;
line: TStringList;
factory: TReleaserObjectFactory;
i, lineNumber, j: Integer;
newVerStr, logicDir, newDir: string;
ifStack: array of TIfState;
skipCommand: boolean;
function PeekIfStack: TIfState;
begin
if ifStack = nil then
result := isNone
else result := ifStack[high(ifStack)];
end;
procedure PokeIfStack(AValue: TIfState);
begin
if ifStack <> nil then
ifStack[high(ifStack)] := AValue;
end;
procedure PopIfStack;
begin
if ifStack <> nil then
setlength(ifStack, length(ifStack)-1);
end;
procedure PushIfStack(AValue: TIfState);
begin
setlength(ifStack, length(ifStack)+1);
ifStack[high(ifStack)] := AValue;
end;
begin
AFilename := ExpandFileName(AFilename);
writeln('Logic file "', AFilename,'"');
assignfile(t, AFilename);
reset(t);
line := TStringList.Create;
objs := TReleaserObjectList.Create;
lineNumber := 0;
ifStack := nil;
try
while not eof(t) do
begin
inc(lineNumber);
readln(t, s);
line.CommaText:= trim(s);
if line.Count > 0 then
begin
cmd := line[0];
line.Delete(0);
skipCommand := false;
if (cmd = 'end') and (PeekIfStack <> isNone) then
begin
PopIfStack;
skipCommand:= true;
end;
if (cmd = 'else') and (PeekIfStack in[isDoTrue,isSkipTrue]) then
begin
if PeekIfStack = isDoTrue then
PokeIfStack(isSkipFalse)
else PokeIfStack(isDoFalse);
skipCommand:= true;
end;
if not skipCommand and (PeekIfStack in[isSkipTrue,isSkipFalse]) then
skipCommand:= true;
factory := nil;
if not skipCommand then
case LowerCase(cmd) of
'cd': begin
if line.Count <> 1 then raise exception.Create('Expecting directory');
logicDir := ExtractFilePath(AFilename);
delete(logicDir, length(logicDir), 1);
newDir := StringReplace(AdaptPathDelim(line[0]),'($LogicDir)',logicDir,[rfReplaceAll]);
SetCurrentDir(newDir);
end;
'manager': factory := TManagerFile;
'archive': factory := TArchiveUrl;
'package': factory := TPackageFile;
'project': factory := TProjectFile;
'bundle': factory := TMacBundle;
'const': factory := TConstFile;
'echo': for i := 0 to line.Count-1 do writeln(line[i]);
'text': factory := TTextLine;
'copy': factory := TCopyFile;
'if': begin
if line.Count = 0 then
raise exception.Create('Expecting condition');
if line[0] = 'exists' then
begin
if line.Count <> 2 then
raise exception.Create('Expecting 1 parameter');
if FileExists(line[1]) or DirectoryExists(line[1]) then
PushIfStack(isDoTrue)
else PushIfStack(isSkipTrue);
end else
raise exception.Create('Unknown condition "'+line[0]);
end;
'else', 'end': raise exception.Create('Unexpected branching "'+cmd+'"');
else
raise exception.Create('Unknown command "'+cmd+'"');
end;
if Assigned(factory) then
begin
if factory.IsUnique then
begin
for i := 0 to objs.Count-1 do
if objs[i] is factory then
raise exception.Create('Unicity constraint not satisfied for '+factory.ClassName);
end;
objs.Add(factory.Create(line, logicDir));
end;
end;
end;
lineNumber := 0;
for i := 0 to objs.Count-1 do
for j := 0 to objs.Count-1 do
objs[i].LinkWith(objs[j]);
ver := GetVersion;
for i := 0 to objs.Count-1 do
objs[i].CheckVersion(ver);
writeln('Current version: ',VersionToStr(ver));
newVerStr := '';
for i := 0 to AOptions.Count-1 do
if AOptions[i].StartsWith('version=') then
begin
newVerStr := copy(AOptions[i], length('version=')+1, length(AOptions[i])-length('version='));
break;
end;
if newVerStr = '' then
begin
write('New version (press Enter to keep the same): ');
readln(newVerStr);
end else
writeln('New version: ', newVerStr);
if Trim(newVerStr)='' then newVer := ver
else newVer := StrToVersion(newVerStr);
if newVer <> ver then
begin
for i := 0 to objs.Count-1 do
objs[i].UpdateVersion(newVer);
end else
begin
for i := 0 to objs.Count-1 do
if (objs[i] is TConstFile) or (objs[i] is TCopyFile) then //constants and copied files are loosely checked
objs[i].UpdateVersion(newVer);
end;
for i := 0 to objs.Count-1 do
objs[i].Save;
writeln('Done.');
except
on ex:exception do
begin
write('Error');
if lineNumber <> 0 then write(' on line ',lineNumber);
writeln(': ', ex.Message);
end;
end;
objs.Free;
line.Free;
closefile(t);
end;
destructor TReleaserApp.Destroy;
begin
inherited Destroy;
end;
procedure TReleaserApp.WriteHelp;
begin
{ add your help code here }
writeln('Update version number and check its consistence.');
writeln;
writeln('Usage: ', ExeName, ' [logicfile1 logicfile2...] [--version=versionNb] [--help]');
writeln;
writeln(' Parameter Description');
writeln(' --------- ----------------------------------------------------------------');
writeln(' versionNb New version number to assign to manager and packages');
writeln;
writeln(' logicfile File containing the location of the version number. If it is not');
writeln(' specified, all logic files in current directory are processed.');
writeln;
writeln(' Sample file: mylib.logic');
writeln(' ----------------------------------------------------------------');
writeln(' cd /mylib');
writeln(' manager update_mylib.json');
writeln(' archive https://github.com/mylib/mylib/archive/v$(Version).zip');
writeln(' package mylib/mylibpack1.lpk');
writeln(' package mylib/mylibpack2.lpk');
writeln(' const mylib/mylibtypes.pas MyLibVersion');
writeln;
writeln(' Sample file: myprog.logic');
writeln(' ----------------------------------------------------------------');
writeln(' cd ($LogicDir)');
writeln(' project myproject.lpi');
writeln(' const myconsts.pas MyProjectVersion');
writeln;
end;
var
Application: TReleaserApp;
begin
Application:=TReleaserApp.Create(nil);
Application.Title:='Releaser';
Application.Run;
Application.Free;
end.

199
bgrabitmap/dev/releaser/releasertypes.pas Normal file
View File

@@ -0,0 +1,199 @@
// SPDX-License-Identifier: LGPL-3.0-linking-exception
unit ReleaserTypes;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fgl;
type
TVersion = record
case boolean of
false: (Value: array[1..4] of integer);
true: (Major, Minor, Release, Build: integer);
end;
operator =(AVersion1,AVersion2: TVersion): boolean;
function VersionToStr(AVersion: TVersion; AAlwaysIncludeZero: boolean = false): string;
function StrToVersion(AStr: string): TVersion;
type
{ TReleaserObject }
TReleaserObject = class
private
function GetParam(AIndex: integer): string;
function GetParamCount: integer;
protected
FLogicDir: string;
function ReplaceVariables(AText: string; AVersion: TVersion): string; overload;
function ReplaceVariables(AText: string): string; overload;
public
FParameters: TStringList;
constructor Create(AParameters: TStringList; ALogicDir: string); virtual;
procedure ExpectParamCount(ACount: integer);
destructor Destroy; override;
property ParamCount: integer read GetParamCount;
property Param[AIndex: integer]: string read GetParam;
class function IsUnique: boolean; virtual;
procedure LinkWith({%H-}AOtherObject: TReleaserObject); virtual;
procedure GetVersions(AVersionList: TStringList); virtual; abstract;
procedure CheckVersion({%H-}AVersion: TVersion); virtual;
procedure UpdateVersion({%H-}AVersion: TVersion); virtual;
procedure Save; virtual; abstract;
end;
TReleaserObjectFactory = class of TReleaserObject;
TReleaserObjectList = specialize TFPGObjectList<TReleaserObject>;
function AdaptPathDelim(APath: string): string;
function DetectLineEnding(AFilename: string): string;
implementation
operator=(AVersion1, AVersion2: TVersion): boolean;
begin
result := (AVersion1.Major = AVersion2.Major) and
(AVersion1.Minor = AVersion2.Minor) and
(AVersion1.Release = AVersion2.Release) and
(AVersion1.Build = AVersion2.Build);
end;
function VersionToStr(AVersion: TVersion; AAlwaysIncludeZero: boolean): string;
begin
result := IntToStr(AVersion.Major);
if AAlwaysIncludeZero or (AVersion.Minor<>0) or (AVersion.Release<>0) or (AVersion.Build<>0) then
begin
result += '.' + IntToStr(AVersion.Minor);
if AAlwaysIncludeZero or (AVersion.Release<>0) or (AVersion.Build<>0) then
begin
result += '.' + IntToStr(AVersion.Release);
if AAlwaysIncludeZero or (AVersion.Build<>0) then
begin
result += '.' + IntToStr(AVersion.Build);
end;
end;
end;
end;
function StrToVersion(AStr: string): TVersion;
var
lst: TStringList;
i: Integer;
begin
lst := TStringList.Create;
lst.Delimiter:= '.';
lst.DelimitedText := AStr;
if lst.Count > 4 then
begin
lst.Free;
raise exception.Create('Invalid version string');
end;
for i := 1 to 4 do result.Value[i] := 0;
for i := 1 to lst.Count do
result.Value[i] := StrToInt(lst[i-1]);
lst.Free;
end;
function AdaptPathDelim(APath: string): string;
begin
if PathDelim <> '\' then
result := StringReplace(APath, '\', PathDelim, [rfReplaceAll]);
if PathDelim <> '/' then
result := StringReplace(APath, '/', PathDelim, [rfReplaceAll]);
end;
function DetectLineEnding(AFilename: string): string;
var t: TextFile;
c, c2: char;
begin
result := LineEnding;
AssignFile(t, AFilename);
Reset(t);
repeat
read(t, c);
if c in[#13,#10] then
begin
result := c;
if not eof(t) then
begin
read(t, c2);
if (c2 in [#13,#10]) and (c2 <> c) then
result += c2;
end;
break;
end;
until eof(t);
CloseFile(t);
end;
{ TReleaserObject }
function TReleaserObject.GetParam(AIndex: integer): string;
begin
result := FParameters[AIndex];
end;
function TReleaserObject.GetParamCount: integer;
begin
result := FParameters.Count;
end;
function TReleaserObject.ReplaceVariables(AText: string; AVersion: TVersion): string;
begin
result := AText;
result := StringReplace(result, '$(Version)', VersionToStr(AVersion), [rfIgnoreCase,rfReplaceAll]);
result := StringReplace(result, '$(LogicDir)', FLogicDir, [rfIgnoreCase,rfReplaceAll]);
end;
function TReleaserObject.ReplaceVariables(AText: string): string;
begin
result := AText;
result := StringReplace(result, '$(Version)', '?', [rfIgnoreCase,rfReplaceAll]);
result := StringReplace(result, '$(LogicDir)', FLogicDir, [rfIgnoreCase,rfReplaceAll]);
end;
constructor TReleaserObject.Create(AParameters: TStringList; ALogicDir: string);
begin
FParameters := TStringList.Create;
FParameters.AddStrings(AParameters);
FLogicDir := ALogicDir;
end;
procedure TReleaserObject.ExpectParamCount(ACount: integer);
begin
if ACount <> ParamCount then
raise exception.Create('Invalid number of parameters. Found '+inttostr(ParamCount)+' but expected '+inttostr(ACount));
end;
destructor TReleaserObject.Destroy;
begin
FParameters.Free;
inherited Destroy;
end;
class function TReleaserObject.IsUnique: boolean;
begin
result := false;
end;
procedure TReleaserObject.LinkWith(AOtherObject: TReleaserObject);
begin
//nothing
end;
procedure TReleaserObject.CheckVersion(AVersion: TVersion);
begin
//nothing
end;
procedure TReleaserObject.UpdateVersion(AVersion: TVersion);
begin
//nothing
end;
end.

150
bgrabitmap/dev/releaser/textline.pas Normal file
View File

@@ -0,0 +1,150 @@
// SPDX-License-Identifier: LGPL-3.0-linking-exception
unit TextLine;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, ReleaserTypes;
type
{ TTextLine }
TTextLine = class(TReleaserObject)
private
FFilename, FTextLine: String;
FTextLineStart, FTextLineEnd: integer;
FVersion: TVersion;
FText: string;
FChanged: boolean;
public
constructor Create(AParameters: TStringList; ALogicDir: string); override;
destructor Destroy; override;
procedure Save; override;
function GetLineForVersion(AVersion: TVersion): string;
procedure GetVersions({%H-}AVersionList: TStringList); override;
procedure CheckVersion(AVersion: TVersion); override;
procedure UpdateVersion(AVersion: TVersion); override;
end;
implementation
{ TTextLine }
constructor TTextLine.Create(AParameters: TStringList; ALogicDir: string);
var
str: TStringStream;
stream: TFileStream;
begin
inherited Create(AParameters, ALogicDir);
ExpectParamCount(2);
FFilename := ExpandFileName(ReplaceVariables(Param[0]));
FTextLine := Param[1];
FTextLineStart:= 0;
FTextLineEnd:= 0;
stream := nil;
str := nil;
try
stream := TFileStream.Create(FFilename, fmOpenRead);
str := TStringStream.Create('');
if str.CopyFrom(stream, stream.Size)<>stream.Size then
raise exception.Create('Unable to read file');
FText := str.DataString;
finally
str.Free;
stream.Free;
end;
end;
destructor TTextLine.Destroy;
begin
inherited Destroy;
end;
procedure TTextLine.Save;
var
stream: TFileStream;
begin
if FChanged then
begin
writeln('Updating text file "',ExtractFileName(FFilename),'"');
stream := TFileStream.Create(FFilename, fmCreate);
try
if FText <> '' then
stream.WriteBuffer(FText[1], length(FText));
finally
stream.Free;
end;
end;
end;
function TTextLine.GetLineForVersion(AVersion: TVersion): string;
begin
result := ReplaceVariables(FTextLine, AVersion);
end;
procedure TTextLine.GetVersions(AVersionList: TStringList);
begin
//nothing
end;
procedure TTextLine.CheckVersion(AVersion: TVersion);
var
i, start: Integer;
expectLine: string;
procedure TryLine(AEnd: integer);
var
curLine: String;
begin
if AEnd > start then
begin
curLine := copy(FText, start, AEnd-start);
if curLine = expectLine then
begin
FTextLineStart:= start;
FTextLineEnd:= AEnd;
FVersion := AVersion;
end;
end;
start := AEnd+1;
end;
begin
inherited CheckVersion(AVersion);
if FTextLineEnd > FTextLineStart then exit;
expectLine := GetLineForVersion(AVersion);
i := 1;
start := 1;
while (i < length(FText)) and (FTextLineEnd <= FTextLineStart) do
begin
if FText[i] in[#13,#10] then TryLine(i);
inc(i);
end;
if (FTextLineEnd <= FTextLineStart) then TryLine(i);
if FTextLineEnd > FTextLineStart then
writeln('Text file "',ExtractFileName(FFilename),'" line found')
else
writeln('Text file "',ExtractFileName(FFilename),'" line not found');
end;
procedure TTextLine.UpdateVersion(AVersion: TVersion);
var
newLine: String;
begin
if AVersion = FVersion then exit;
newLine := GetLineForVersion(AVersion);
if FTextLineEnd > FTextLineStart then
begin
delete(FText, FTextLineStart, FTextLineEnd-FTextLineStart);
insert(newLine, FText, FTextLineStart);
FTextLineEnd:= FTextLineStart+length(newLine);
FChanged:= true;
end else
writeln('Please add manually a line "',newLine,'" in "',ExtractFileName(FFilename),'"');
end;
end.