paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-07-08 15:25:59 +02:00
Code Issues Packages Projects Releases Wiki Activity

IDE: Do not write unchanged resource file to disk. Issue #15915.

Browse Source
This commit is contained in:
Juha 2022-10-06 16:46:08 +03:00
parent fd32bba5eb
commit a624d0c027
1 changed files with 69 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
ide/projectresources.pas
View File

@ -67,10 +67,9 @@ type
FSystemResources: TResources; FSystemResources: TResources;
FLazarusResources: TStringList; FLazarusResources: TStringList;
resFileName: String; resFileName, lrsFileName: String;
lrsFileName: String; LastResFileName, LastLrsFileName: String;
LastResFileName: String; LastSavedRes: String;
LastLrsFileName: String;
function GetProjectIcon: TProjectIcon; function GetProjectIcon: TProjectIcon;
function GetProjectUserResources: TProjectUserResources; function GetProjectUserResources: TProjectUserResources;
@ -82,7 +81,8 @@ type
function UpdateMainSourceFile(const AFileName: string): Boolean; function UpdateMainSourceFile(const AFileName: string): Boolean;
procedure UpdateFlagLrsIncludeAllowed(const AFileName: string); procedure UpdateFlagLrsIncludeAllowed(const AFileName: string);
function Save(SaveToTestDir: string): Boolean; function Save(SaveToTestDir: string): Boolean;
procedure UpdateCodeBuffers; function UpdateResCodeBuffer: Boolean;
procedure UpdateLrsCodeBuffer;
procedure DeleteLastCodeBuffers; procedure DeleteLastCodeBuffers;
procedure OnResourceModified(Sender: TObject); procedure OnResourceModified(Sender: TObject);
@ -100,8 +100,7 @@ type
procedure DoBeforeBuild(AReason: TCompileReason; SaveToTestDir: boolean); procedure DoBeforeBuild(AReason: TCompileReason; SaveToTestDir: boolean);
procedure Clear; procedure Clear;
function Regenerate(const MainFileName: String; function Regenerate(const MainFileName: String;
UpdateSource, PerformSave: boolean; UpdateSource, PerformSave: boolean; const SaveToTestDir: string): Boolean;
const SaveToTestDir: string): Boolean;
function RenameDirectives(const CurFileName, NewFileName: String): Boolean; function RenameDirectives(const CurFileName, NewFileName: String): Boolean;
procedure DeleteResourceBuffers; procedure DeleteResourceBuffers;
@ -505,16 +504,14 @@ begin
FMessages.Clear; FMessages.Clear;
end; end;
function TProjectResources.Regenerate(const MainFileName: String; UpdateSource, function TProjectResources.Regenerate(const MainFileName: String;
PerformSave: boolean; const SaveToTestDir: string): Boolean; UpdateSource, PerformSave: boolean; const SaveToTestDir: string): Boolean;
begin begin
//DebugLn(['TProjectResources.Regenerate MainFilename=',MainFilename, //DebugLn(['TProjectResources.Regenerate MainFilename=',MainFilename,
// ' UpdateSource=',UpdateSource,' PerformSave=',PerformSave]); // ' UpdateSource=',UpdateSource,' PerformSave=',PerformSave]);
//DumpStack; //DumpStack;
Result := False; Result := False;
Assert(MainFileName<>'', 'TProjectResources.Regenerate: MainFileName is empty.');
if (MainFileName = '') then
Exit(true);
// remember old codebuffer filenames // remember old codebuffer filenames
LastResFileName := resFileName; LastResFileName := resFileName;
@ -529,8 +526,16 @@ begin
debugln(['TProjectResources.Regenerate Update failed']); debugln(['TProjectResources.Regenerate Update failed']);
Exit; Exit;
end; end;
// create codebuffers of new .lrs and .rc files if LastSavedRes='' then begin
UpdateCodeBuffers; // ToDo: Read an existing .res file from disk into LastSavedRes
// to know if a new resource should be saved.
// Now it gets saved once the first time after IDE started.
end;
// codebuffer of new .res file
if not UpdateResCodeBuffer and (LastResFileName=resFileName) then
PerformSave := False; // Do not save an unchanged resource file.
// codebuffer of new .lrs file
UpdateLrsCodeBuffer;
// update .lpr file (old and new include files exist, so parsing should work without errors) // update .lpr file (old and new include files exist, so parsing should work without errors)
if UpdateSource and not UpdateMainSourceFile(MainFileName) then begin if UpdateSource and not UpdateMainSourceFile(MainFileName) then begin
debugln(['TProjectResources.Regenerate UpdateMainSourceFile failed']); debugln(['TProjectResources.Regenerate UpdateMainSourceFile failed']);
@ -730,8 +735,9 @@ begin
UpdateFlagLrsIncludeAllowed(CurFileName); UpdateFlagLrsIncludeAllowed(CurFileName);
if not Update then if not Update then
Exit; Exit;
// update codebuffers of new .lrs and .res files // update codebuffers of new .res and .lrs files
UpdateCodeBuffers; UpdateResCodeBuffer;
UpdateLrsCodeBuffer;
// update {$I filename} directive // update {$I filename} directive
if CodeToolBoss.FindIncludeDirective(CodeBuf, 1, 1, if CodeToolBoss.FindIncludeDirective(CodeBuf, 1, 1,
@ -780,14 +786,11 @@ end;
function TProjectResources.Save(SaveToTestDir: string): Boolean; function TProjectResources.Save(SaveToTestDir: string): Boolean;
function SaveCodeBuf(Filename: string): boolean; function SaveCodeBuf(CodeBuf: TCodeBuffer): boolean;
var var
CodeBuf: TCodeBuffer;
TestFilename: String; TestFilename: String;
begin begin
Result := True; Result := True;
CodeBuf := CodeToolBoss.FindFile(Filename);
if (CodeBuf = nil) or CodeBuf.IsDeleted then Exit;
if not CodeBuf.IsVirtual then if not CodeBuf.IsVirtual then
Result := SaveCodeBuffer(CodeBuf) in [mrOk,mrIgnore] Result := SaveCodeBuffer(CodeBuf) in [mrOk,mrIgnore]
else if SaveToTestDir<>'' then else if SaveToTestDir<>'' then
@ -797,39 +800,58 @@ function TProjectResources.Save(SaveToTestDir: string): Boolean;
end; end;
end; end;
begin
Result := False;
if not SaveCodeBuf(resFileName) then Exit;
if not SaveCodeBuf(lrsFileName) then Exit;
Result := True;
end;
procedure TProjectResources.UpdateCodeBuffers;
var var
CodeBuf: TCodeBuffer; CodeBuf: TCodeBuffer;
S: TStream; begin
Result := False;
// Save .res
CodeBuf := CodeToolBoss.FindFile(resFilename);
if Assigned(CodeBuf) and not CodeBuf.IsDeleted then
begin
Result := SaveCodeBuf(CodeBuf);
if not Result then Exit;
//DebugLn(['TProjectResources.Save: Res len=', Length(CodeBuf.Source),
// ', LastRes len=', Length(LastSavedRes)]);
LastSavedRes := CodeBuf.Source;
end;
// Save .lrs
CodeBuf := CodeToolBoss.FindFile(lrsFilename);
if Assigned(CodeBuf) and not CodeBuf.IsDeleted then
Result := SaveCodeBuf(CodeBuf);
end;
function TProjectResources.UpdateResCodeBuffer: Boolean;
// Generate .res resource and return True if it differs from the last saved one.
var
CodeBuf: TCodeBuffer;
ResStream: TStream;
Writer: TAbstractResourceWriter; Writer: TAbstractResourceWriter;
begin begin
if HasSystemResources then Result := False;
begin if not HasSystemResources then Exit;
CodeBuf := CodeToolBoss.CreateFile(resFileName); CodeBuf := CodeToolBoss.CreateFile(resFileName);
S := TMemoryStream.Create; ResStream := TMemoryStream.Create;
Writer := TResResourceWriter.Create; Writer := TResResourceWriter.Create;
try try
FSystemResources.WriteToStream(S, Writer); FSystemResources.WriteToStream(ResStream, Writer);
S.Position := 0; ResStream.Position := 0;
CodeBuf.LoadFromStream(S); CodeBuf.LoadFromStream(ResStream);
Result := CodeBuf.Source <> LastSavedRes;
finally finally
Writer.Free; Writer.Free;
S.Free; ResStream.Free;
end; end;
end; end;
if FLrsIncludeAllowed and HasLazarusResources then
procedure TProjectResources.UpdateLrsCodeBuffer;
// Generate .lrs resource.
var
CodeBuf: TCodeBuffer;
begin begin
if not (FLrsIncludeAllowed or HasLazarusResources) then Exit;
CodeBuf := CodeToolBoss.CreateFile(lrsFileName); CodeBuf := CodeToolBoss.CreateFile(lrsFileName);
CodeBuf.Source := FLazarusResources.Text; CodeBuf.Source := FLazarusResources.Text;
end; end;
end;
procedure TProjectResources.DeleteLastCodeBuffers; procedure TProjectResources.DeleteLastCodeBuffers;