* Added option to intitialize the repository test environment
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4383 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
loesje_
parent
5b07289442
commit
9ddd49bfcd
@ -6,8 +6,13 @@ uses
|
||||
{$IFDEF UNIX}
|
||||
cthreads,
|
||||
{$ENDIF}
|
||||
{$IFDEF WINDOWS}
|
||||
ShellApi,
|
||||
windows,
|
||||
{$ENDIF}
|
||||
Classes,
|
||||
SysUtils,
|
||||
process,
|
||||
CustApp,
|
||||
pkgrepos,
|
||||
pkgoptions,
|
||||
@ -34,12 +39,16 @@ type
|
||||
FJsonCommandArr: TJSONArray;
|
||||
FCurrentCommand: TJSONObject;
|
||||
FRepoDir: String;
|
||||
FStartCompiler: String;
|
||||
function GetJsonLogArray(ForceCreate: Boolean): TJSONArray;
|
||||
function SetupRepository(): Boolean;
|
||||
function LastError: String;
|
||||
procedure LoadIniFile();
|
||||
function ExecuteProcess(ACmd: string; AParamList: array of const): boolean;
|
||||
function RemoveTree(APath: String): Boolean;
|
||||
protected
|
||||
procedure DoRun; override;
|
||||
procedure InitializeRepository();
|
||||
procedure TestPackage(APackageName: String);
|
||||
procedure TestSinglePackage(APackage: TFPPackage);
|
||||
public
|
||||
@ -132,17 +141,102 @@ begin
|
||||
IniFile := TIniFile.Create(CfgFile);
|
||||
try
|
||||
FRepoDir := IncludeTrailingPathDelimiter(ExpandFileName(IniFile.ReadString('Settings','repodir','repotest')));
|
||||
FStartCompiler := ExpandFileName(IniFile.ReadString('Settings','startcompiler','ppc386'+ExeExt));
|
||||
finally
|
||||
IniFile.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TfppkgRepoTest.ExecuteProcess(ACmd: string; AParamList: array of const): boolean;
|
||||
var
|
||||
P: TProcess;
|
||||
i: Integer;
|
||||
begin
|
||||
result := False;
|
||||
P := TProcess.Create(nil);
|
||||
try
|
||||
P.Executable:=ACmd;
|
||||
for i := 0 to high(AParamList) do
|
||||
begin
|
||||
if AParamList[i].VType=vtAnsiString then
|
||||
P.Parameters.Add(ansistring(AParamList[i].VAnsiString))
|
||||
else
|
||||
raise exception.CreateFmt('parameter type %d not supported',[AParamList[i].VType]);
|
||||
end;
|
||||
P.Options:=[poWaitOnExit];
|
||||
P.Execute;
|
||||
result := P.ExitCode=0;
|
||||
finally
|
||||
P.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TfppkgRepoTest.RemoveTree(APath: String): Boolean;
|
||||
|
||||
var
|
||||
{$ifdef MSWINDOWS}
|
||||
SHFileOpStruct: TSHFileOpStruct;
|
||||
DirBuf: array[0..MAX_PATH+1] of TCHAR;
|
||||
{$else MSWINDOWS}
|
||||
searchRec: TSearchRec;
|
||||
SearchResult: longint;
|
||||
s: string;
|
||||
{$endif MSWINDOWS}
|
||||
|
||||
begin
|
||||
result := true;
|
||||
{$ifdef MSWINDOWS}
|
||||
try
|
||||
FillChar(SHFileOpStruct, Sizeof(SHFileOpStruct), 0);
|
||||
FillChar(DirBuf, Sizeof(DirBuf), 0);
|
||||
StrPCopy(DirBuf, APath);
|
||||
with SHFileOpStruct do
|
||||
begin
|
||||
pFrom := @DirBuf;
|
||||
wFunc := FO_DELETE;
|
||||
fFlags := FOF_NOCONFIRMATION or FOF_SILENT;
|
||||
end;
|
||||
Result := SHFileOperation(SHFileOpStruct) = 0;
|
||||
except
|
||||
Result := False;
|
||||
end;
|
||||
{$else MSWINDOWS}
|
||||
SearchResult := FindFirst(IncludeTrailingPathDelimiter(ADirectoryName)+AllFilesMask, faAnyFile+faSymLink, searchRec);
|
||||
try
|
||||
while SearchResult=0 do
|
||||
begin
|
||||
if (searchRec.Name<>'.') and (searchRec.Name<>'..') then
|
||||
begin
|
||||
s := IncludeTrailingPathDelimiter(ADirectoryName)+searchRec.Name;
|
||||
if (searchRec.Attr and faDirectory)=faDirectory then
|
||||
begin
|
||||
if not IntRemoveTree(s) then
|
||||
result := false;
|
||||
end
|
||||
else if not DeleteFile(s) then
|
||||
result := False
|
||||
else
|
||||
log(vldebug, SDbgDeletedFile, [s]);
|
||||
end;
|
||||
SearchResult := FindNext(searchRec);
|
||||
end;
|
||||
finally
|
||||
FindClose(searchRec);
|
||||
end;
|
||||
|
||||
// There were reports of RemoveDir failing due to locking-problems. To solve
|
||||
// these the RemoveDir is tried three times, with a delay of 5 seconds. See
|
||||
// bug 21868
|
||||
result := RemoveDir(ADirectoryName);
|
||||
{$endif WINDOWS}
|
||||
end;
|
||||
|
||||
procedure TfppkgRepoTest.DoRun;
|
||||
var
|
||||
ErrorMsg: String;
|
||||
begin
|
||||
// quick check parameters
|
||||
ErrorMsg:=CheckOptions('htdv', ['help','test','init']);
|
||||
ErrorMsg:=CheckOptions('htidv', ['help','test','initializerepository']);
|
||||
if ErrorMsg<>'' then
|
||||
begin
|
||||
ShowException(Exception.Create(ErrorMsg));
|
||||
@ -171,12 +265,66 @@ begin
|
||||
TestPackage(GetOptionValue('t','test'));
|
||||
end;
|
||||
|
||||
if HasOption('i','initializerepository') then
|
||||
begin
|
||||
InitializeRepository();
|
||||
end;
|
||||
|
||||
// stop program loop
|
||||
Terminate;
|
||||
|
||||
WriteLn(FJsonResult.FormatJSON);
|
||||
end;
|
||||
|
||||
procedure TfppkgRepoTest.InitializeRepository;
|
||||
var
|
||||
FpcmkcfgBin: string;
|
||||
FpcPath: string;
|
||||
FpccfgName: string;
|
||||
FpcBin: string;
|
||||
sr: TSearchRec;
|
||||
UnitDir: string;
|
||||
begin
|
||||
if not DirectoryExistsLog(FRepoDir+'fpcsrc') then
|
||||
begin
|
||||
writeln('Not a valid repository-test directory: '+FRepoDir);
|
||||
Exit;
|
||||
end;
|
||||
SetCurrentDir(FRepoDir+'fpcsrc');
|
||||
if not ExecuteProcess('svn'+ExeExt,['update']) then
|
||||
raise exception.create('Failed to run svn update');
|
||||
if not ExecuteProcess('make'+ExeExt, ['clean', 'all', 'PP="'+FStartCompiler+'"', 'FPMAKEOPT="-T 4"']) then
|
||||
raise exception.create('Failed to compile fpc');
|
||||
RemoveDir(FRepoDir+'fpc');
|
||||
if not ExecuteProcess('make'+ExeExt, ['install', 'PREFIX="'+FRepoDir+'fpc"']) then
|
||||
raise exception.create('Failed to install fpc');
|
||||
|
||||
FpcmkcfgBin:=FRepoDir+'fpc'+DirectorySeparator+'bin'+DirectorySeparator+'i386-win32'+DirectorySeparator+'fpcmkcfg'+ExeExt;
|
||||
FpcPath:=FRepoDir+'fpc';
|
||||
FpccfgName:=FRepoDir+'fpc'+DirectorySeparator+'bin'+DirectorySeparator+'i386-win32'+DirectorySeparator+'fpc.cfg';
|
||||
FpcBin:=FRepoDir+'fpc'+DirectorySeparator+'bin'+DirectorySeparator+'i386-win32'+DirectorySeparator+'ppc386'+ExeExt;
|
||||
UnitDir:=FRepoDir+'fpc'+DirectorySeparator+'units'+DirectorySeparator+'i386-win32'+DirectorySeparator;
|
||||
|
||||
if not ExecuteProcess(FpcmkcfgBin, ['-p', '-d "basepath='+FpcPath+'"', '-d "basepath='+FpcPath+'"', '-o "'+FpccfgName+'"']) then
|
||||
raise exception.create('Failed to create fpc.cfg');
|
||||
if not ExecuteProcess(FpcmkcfgBin, ['-p', '-3','-d "LocalRepository='+FRepoDir+'fppkg'+DirectorySeparator+'"', '-o "'+FRepoDir+'etc'+DirectorySeparator+'fppkg.cfg"']) then
|
||||
raise exception.create('Failed to create fppkg.cfg');
|
||||
if not ExecuteProcess(FpcmkcfgBin, ['-p', '-4', '-d "GlobalPrefix='+FpcPath+'"', '-d "FpcBin='+FpcBin+'"', '-o "'+FRepoDir+'fppkg'+DirectorySeparator+'config'+DirectorySeparator+'default"']) then
|
||||
raise exception.create('Failed to create fppkg.cfg');
|
||||
|
||||
RemoveTree(FRepoDir+'fpc'+DirectorySeparator+'fpmkinst');
|
||||
|
||||
if FindFirst(UnitDir+AllFiles, faDirectory, sr) = 0 then
|
||||
begin
|
||||
repeat
|
||||
if (sr.Name <> 'rtl') and (sr.Name <> '.') and (sr.Name <> '..') then
|
||||
begin
|
||||
RemoveTree(UnitDir+sr.Name);
|
||||
end;
|
||||
until FindNext(sr)<>0;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TfppkgRepoTest.TestSinglePackage(APackage: TFPPackage);
|
||||
var
|
||||
|
||||
Loading…
Reference in New Issue
Block a user