1 { $Id: testlpi.pas 54031 2017-01-29 21:04:32Z joost $}
2 { Copyright (C) 2006 Vincent Snijders
3
4 This source is free software; you can redistribute it and/or modify it under
5 the terms of the GNU General Public License as published by the Free
6 Software Foundation; either version 2 of the License, or (at your option)
7 any later version.
8
9 This code is distributed in the hope that it will be useful, but WITHOUT ANY
10 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
11 FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
12 details.
13
14 A copy of the GNU General Public License is available on the World Wide Web
15 at <http://www.gnu.org/copyleft/gpl.html>. You can also obtain it by writing
16 to the Free Software Foundation, Inc., 51 Franklin Street - Fifth Floor,
17 Boston, MA 02110-1335, USA.
18 }
19 unit TestLpi;
20
21 {$mode objfpc}{$H+}
22
23 interface
24
25 uses
26 Classes, SysUtils, strutils, fpcunit, testregistry, process, UTF8Process,
27 InterfaceBase, LCLPlatformDef, LazFileUtils, LazUTF8, FileUtil,
28 TestGlobals;
29
30 type
31
32 { TLpkTest }
33
34 TLpkTest = class(TTestCase)
35 private
36 FPath: string;
37 public
38 constructor Create(const APath: string; const ATestName: string); overload;
GetExtensionnull39 class function GetExtension: string; virtual;
CreateSuiteFromFilenull40 class function CreateSuiteFromFile(const aName, APath: string): TTestSuite; virtual;
CreateSuiteFromDirectorynull41 class function CreateSuiteFromDirectory(const AName, ABasePath: string): TTestSuite;
42 published
43 procedure TestCompile;
44 end;
45
46 { TLpiTest }
47
48 TLpiTest= class(TLpkTest)
49 private
50 procedure RunScript;
51 public
GetExtensionnull52 class function GetExtension: string; override;
CreateSuiteFromFilenull53 class function CreateSuiteFromFile(const aName, APath: string): TTestSuite; override;
54 published
55 procedure TestRun;
56 end;
57
58 implementation
59
60 var
61 LazarusDir: string;
62 ComponentsDir: String;
63 ExamplesDir: string;
64 CTExamplesDir: string;
65 LCLTestDir: string;
66 ScriptEngine: string;
67
68 procedure InitDirectories;
69 begin
70 LazarusDir := ExpandFileNameUTF8(ExtractFilePath(ParamStrUTF8(0)) + '../');
71 ComponentsDir := SetDirSeparators(LazarusDir + 'components/');
72 ExamplesDir := LazarusDir + 'examples' + PathDelim;
73 CTExamplesDir := SetDirSeparators(ComponentsDir + 'codetools/examples/');
74 LCLTestDir := LazarusDir + 'lcl' + PathDelim + 'tests' + PathDelim;
75 ScriptEngine := 'C:\Program Files\AutoHotkey\AutoHotKey.exe';
76 end;
77
GetScriptFileNamenull78 function GetScriptFileName(const LpiFileName: string): string;
79 begin
80 Result := AppendPathDelim(ProgramDirectory) +
81 ExtractFileNameOnly(LpiFileName) +'.ahk';
82 end;
83
84 constructor TLpkTest.Create(const APath: string; const ATestName: string);
85 begin
86 inherited CreateWithName(ATestName);
87 FPath := APath;
88 end;
89
TLpkTest.GetExtensionnull90 class function TLpkTest.GetExtension: string;
91 begin
92 Result := '.lpk';
93 end;
94
TLpkTest.CreateSuiteFromDirectorynull95 class function TLpkTest.CreateSuiteFromDirectory(const AName,
96 ABasePath: string): TTestSuite;
97
98 procedure SearchDirectory(const ADirectory: string);
99 var
100 RelativePath: string;
101 SearchMask: string;
102 FileInfo: TSearchRec;
103 begin
104 SearchMask := ABasePath+ADirectory + '*';
105 if FindFirstUTF8(SearchMask,faAnyFile,FileInfo)=0 then begin
106 repeat
107 // skip special directory entries
108 if (FileInfo.Name='.') or (FileInfo.Name='..') then continue;
109
110 RelativePath := ADirectory+ FileInfo.Name;
111 if RightStr(FileInfo.Name,4)=GetExtension then
112 Result.AddTest(CreateSuiteFromFile(RelativePath, ABasePath+RelativePath))
113 else if (FileInfo.Attr and faDirectory=faDirectory) then
114 SearchDirectory(AppendPathDelim(RelativePath));
115 until FindNextUTF8(FileInfo)<>0;
116 end;
117 FindCloseUTF8(FileInfo);
118 end;
119
120 begin
121 Result := TTestSuite.Create(AName);
122 SearchDirectory('')
123 end;
124
TLpkTest.CreateSuiteFromFilenull125 class function TLpkTest.CreateSuiteFromFile(const AName,
126 APath: string): TTestSuite;
127 begin
128 Result := TTestSuite.Create(AnsiReplaceStr(AName, DirectorySeparator, '/'));
129 Result.AddTest(Create(APath, 'TestCompile'));
130 end;
131
132 procedure TLpkTest.TestCompile;
133 var
134 LazBuildPath: string;
135 LazBuild: TProcessUTF8;
136 OutputLines: TStrings;
137 CmdLine: string;
138 begin
139 LazBuildPath := LazarusDir + 'lazbuild' + GetExeExt;
140 AssertTrue(LazBuildPath + ' does not exist', FileExistsUTF8(LazBuildPath));
141 LazBuild := TProcessUTF8.Create(nil);
142 OutputLines := nil;
143 try
144 {$IFDEF windows}
145 LazBuild.Options := [poNewConsole, poUsePipes];
146 {$ELSE}
147 LazBuild.Options := [poNoConsole, poUsePipes];
148 {$ENDIF}
149 LazBuild.ShowWindow := swoHIDE;
150 CmdLine:=LazBuildPath;
151 if Compiler<>'' then
152 CmdLine:=Cmdline + ' --compiler='+Compiler;
153 if PrimaryConfigPath<>'' then
154 CmdLine := CmdLine + ' --pcp='+PrimaryConfigPath;
155 Cmdline := Cmdline + ' --ws=' + LCLPlatformDirNames[WidgetSet.LCLPlatform];
156 Cmdline := Cmdline + ' -B ' + FPath;
157 LazBuild.CommandLine := CmdLine;
158 LazBuild.CurrentDirectory := ExtractFileDir(FPath);
159 LazBuild.Execute;
160 OutputLines := ReadOutput(LazBuild);
161 if LazBuild.Running then begin
162 LazBuild.Terminate(99);
163 end;
164 if LazBuild.ExitStatus<>0 then
165 Fail(format('Compilation failed: ExitCode=%d%s%s',
166 [LazBuild.ExitStatus, LineEnding, AnsiToUtf8(OutputLines.Text)]));
167 finally
168 LazBuild.Free;
169 OutputLines.Free;
170 end;
171 end;
172
TLpiTest.GetExtensionnull173 class function TLpiTest.GetExtension: string;
174 begin
175 Result := '.lpi';
176 end;
177
TLpiTest.CreateSuiteFromFilenull178 class function TLpiTest.CreateSuiteFromFile(const AName,
179 APath: string): TTestSuite;
180 {$IFDEF win32}
181 var
182 AhkFileName: String;
183 {$ENDIF}
184 begin
185 Result := inherited CreateSuiteFromFile(AName, APath);
186 {$IFDEF win32}
187 AhkFileName := GetScriptFileName(APath);
188 if FileExistsUTF8(AhkFileName) then
189 Result.AddTest(TLpiTest.Create(APath, 'TestRun'));
190 {$ELSE}
191 {$NOTE scripting is only available on win32}
192 {$ENDIF}
193 end;
194
195 procedure TLpiTest.RunScript;
196 var
197 ScriptProcess : TProcessUTF8;
198 begin
199 AssertTrue('ScriptEngine "' + ScriptEngine + '" does not exist.',
200 FileExistsUTF8(ScriptEngine));
201 ScriptProcess := TProcessUTF8.Create(nil);
202 try
203 ScriptProcess.CommandLine := ScriptEngine + ' ' + GetScriptFileName(FPath);
204 ScriptProcess.Execute;
205 ScriptProcess.WaitOnExit;
206 finally
207 ScriptProcess.Free;
208 end;
209 end;
210
211 procedure TLpiTest.TestRun;
212 var
213 TestProcess : TProcessUTF8;
214 ExeName: string;
215 begin
216 ExeName := ChangeFileExt(FPath, GetExeExt);
217 AssertTrue(ExeName + 'does not exist.', FileExistsUTF8(ExeName));
218 TestProcess := TProcessUTF8.Create(nil);
219 try
220 TestProcess.CommandLine := ExeName;
221 TestProcess.Execute;
222 RunScript;
223 TestProcess.WaitOnExit;
224 finally
225 TestProcess.Free;
226 end;
227 end;
228
229 procedure InitializeTestSuites;
230 var
231 ATestSuite: TTestSuite;
232 begin
233 // Create testsuite for projects
234 ATestSuite := TTestSuite.Create('Projects');
235 ATestSuite.AddTest(
236 TLpiTest.CreateSuiteFromDirectory('Examples', ExamplesDir));
237 ATestSuite.AddTest(
238 TLpiTest.CreateSuiteFromDirectory('Codetools Examples', CTExamplesDir));
239 ATestSuite.AddTest(
240 TLpiTest.CreateSuiteFromDirectory('LCL test', LCLTestDir));
241 GetTestRegistry.AddTest(ATestSuite);
242
243 // Create testsuite for packages
244 ATestSuite := TTestSuite.Create('Packages');
245 ATestSuite.AddTest(
246 TLpkTest.CreateSuiteFromDirectory('Components', ComponentsDir));
247 ATestSuite.AddTest(
248 TLpkTest.CreateSuiteFromDirectory('Examples', ExamplesDir));
249 GetTestRegistry.AddTest(ATestSuite);
250 end;
251
252 initialization
253 InitDirectories;
254 InitializeTestSuites;
255 end.
256
257