paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 14:19:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Remove the unit-directory entirely on a distclean. To avoid problems when units got renamed, or in similar circumstances

Browse Source 
git-svn-id: trunk@18055 -
This commit is contained in:
joost 2011-08-01 20:29:22 +00:00
parent 65b41a6c73
commit 7bcf71f342
1 changed files with 73 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
packages/fpmkunit/src/fpmkunit.pp
View File

@ -695,6 +695,7 @@ Type
FBinInstallDir,
FDocInstallDir,
FExamplesInstallDir : String;
FRemoveTree: String;
FRemoveDir: String;
FRemove: String;
FTarget: String;
@ -755,6 +756,7 @@ Type
Property Move : String Read FMove Write FMove; // Move $(FILES) to $(DEST)
Property Remove : String Read FRemove Write FRemove; // Delete $(FILES)
Property RemoveDir : String Read FRemoveDir Write FRemoveDir; // Delete $(FILES)
Property RemoveTree : String Read FRemoveTree Write FRemoveTree; // removes $(DIRECTORY)
Property MkDir : String Read FMkDir write FMkDir; // Make $(DIRECTORY)
Property Archive : String Read FArchive Write FArchive; // zip $(ARCHIVE) $(FILESORDIRS)
// Misc
@ -811,6 +813,7 @@ Type
Procedure SysMoveFile(Const Src,Dest : String); virtual;
Procedure SysDeleteFile(Const AFileName : String); virtual;
Procedure SysDeleteDirectory(Const ADirectoryName : String); virtual;
Procedure SysDeleteTree(Const ADirectoryName : String); virtual;
Procedure SysArchiveFiles(List : TStrings; Const AFileName : String); virtual;
procedure LogIndent;
procedure LogUnIndent;
@ -846,6 +849,7 @@ Type
Procedure CmdArchiveFiles(List : TStrings; Const ArchiveFile : String);
Procedure CmdRenameFile(SourceName, DestName : String);
Procedure CmdRemoveDirs(List: TStrings);
Procedure CmdRemoveTrees(List: TStrings);
Procedure ExecuteCommands(Commands : TCommands; At : TCommandAt);
// Dependency commands
Function DependencyOK(ADependency : TDependency) : Boolean;
@ -1174,6 +1178,7 @@ Const
KeyMove = 'Move';
KeyRemove = 'Remove';
KeyRemoveDir= 'RemoveDir';
KeyRemoveTree= 'RemoveTree';
KeyOptions = 'Options';
KeyCPU = 'CPU';
KeyOS = 'OS';
@ -3035,6 +3040,7 @@ begin
Values[KeyExamplesInstallDir]:=FExamplesInstallDir;
Values[KeyRemove]:=FRemove;
Values[KeyRemoveDir]:=FRemoveDir;
Values[KeyRemoveTree]:=FRemoveTree;
Values[KeyTarget]:=FTarget;
if FNoFPCCfg then
Values[KeyNoFPCCfg]:='Y';
@ -3075,6 +3081,7 @@ begin
FMove:=Values[KeyMove];
FRemove:=Values[KeyRemove];
FRemoveDir:=Values[KeyRemoveDir];
FRemoveTree:=Values[KeyRemoveTree];
Options:=OptionsToStringList(Values[KeyOptions]);
Line:=Values[KeyCPU];
If (Line<>'') then
@ -3698,6 +3705,45 @@ begin
end;
procedure TBuildEngine.SysDeleteTree(const ADirectoryName: String);
function IntRemoveTree(const ADirectoryName: String) : boolean;
var
searchRec: TSearchRec;
SearchResult: longint;
begin
result := true;
SearchResult := FindFirst(IncludeTrailingPathDelimiter(ADirectoryName)+AllFilesMask, faAnyFile+faSymLink, searchRec);
try
while SearchResult=0 do
begin
if (searchRec.Name<>'.') and (searchRec.Name<>'..') then
begin
if (searchRec.Attr and faDirectory)=faDirectory then
begin
if not IntRemoveTree(IncludeTrailingPathDelimiter(ADirectoryName)+searchRec.Name) then
result := false;
end
else if not DeleteFile(IncludeTrailingPathDelimiter(ADirectoryName)+searchRec.Name) then
result := False;
end;
SearchResult := FindNext(searchRec);
end;
finally
FindClose(searchRec);
end;
if not RemoveDir(ADirectoryName) then
result := false;
end;
begin
if not DirectoryExists(ADirectoryName) then
Log(vldebug,SDbgDirectoryDoesNotExist,[ADirectoryName])
else If Not IntRemoveTree(ADirectoryName) then
Error(SErrRemovingDirectory,[ADirectoryName]);
end;
procedure TBuildEngine.SysArchiveFiles(List: TStrings;Const AFileName: String);
begin
If Not (Assigned(OnArchivefiles) or Assigned(ArchiveFilesProc)) then
@ -3873,6 +3919,21 @@ begin
SysDeleteDirectory(List[i]);
end;
procedure TBuildEngine.CmdRemoveTrees(List: TStrings);
Var
Args : String;
I : Integer;
begin
If (Defaults.RemoveTree<>'') then
begin
Args:=FileListToString(List,'');
ExecuteCommand(Defaults.RemoveTree,Args);
end
else
For I:=0 to List.Count-1 do
SysDeleteTree(List[i]);
end;
Function TBuildEngine.FileNewer(const Src,Dest : String) : Boolean;
Var
@ -5026,6 +5087,7 @@ procedure TBuildEngine.Clean(APackage: TPackage; AllTargets: boolean);
var
ACPU: TCpu;
AOS: TOS;
DirectoryList : TStringList;
begin
Log(vlInfo,SInfoCleaningPackage,[APackage.Name]);
try
@ -5034,13 +5096,22 @@ begin
DoBeforeClean(Apackage);
if AllTargets then
begin
for ACPU:=low(TCpu) to high(TCpu) do
// Remove the unit-directory completely. This is safer in case of files
// being renamed and such. See also bug 19655
DirectoryList := TStringList.Create;
try
DirectoryList.Add(ExtractFileDir(APackage.GetUnitsOutputDir(ACPU,AOS)));
CmdRemoveTrees(DirectoryList);
finally
DirectoryList.Free;
end;
{ for ACPU:=low(TCpu) to high(TCpu) do
for AOS:=low(TOS) to high(TOS) do
begin
if FileExists(APackage.GetUnitsOutputDir(ACPU,AOS)) or
FileExists(APackage.GetBinOutputDir(ACPU,AOS)) then
Clean(APackage,ACPU,AOS);
end;
end;}
end
else
Clean(APackage, Defaults.CPU, Defaults.OS);