From 9ddd49bfcdd9883d5ac5097c5b87813a22e51651 Mon Sep 17 00:00:00 2001 From: loesje_ Date: Thu, 5 Nov 2015 18:37:58 +0000 Subject: [PATCH] * 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 --- .../fppkgrepotest/trunk/fppkgrepotest.lpr | 150 +++++++++++++++++- 1 file changed, 149 insertions(+), 1 deletion(-) diff --git a/applications/fppkgrepotest/trunk/fppkgrepotest.lpr b/applications/fppkgrepotest/trunk/fppkgrepotest.lpr index d8a35eb9a..c30f692d6 100644 --- a/applications/fppkgrepotest/trunk/fppkgrepotest.lpr +++ b/applications/fppkgrepotest/trunk/fppkgrepotest.lpr @@ -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