pastounittest.pp 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753
  1. {
  2. This file is part of the Free Component Library
  3. Copyright (c) 2012 by the Free Pascal team
  4. Pascal source to FPC Unit test generator
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. {$IFNDEF FPC_DOTTEDUNITS}
  12. unit pastounittest;
  13. {$ENDIF FPC_DOTTEDUNITS}
  14. {$mode objfpc}{$H+}
  15. interface
  16. {$IFDEF FPC_DOTTEDUNITS}
  17. uses
  18. System.Classes, System.SysUtils, Pascal.Scanner, Pascal.Parser, Pascal.Tree;
  19. {$ELSE FPC_DOTTEDUNITS}
  20. uses
  21. Classes, SysUtils, PScanner, pparser, pastree;
  22. {$ENDIF FPC_DOTTEDUNITS}
  23. Type
  24. TTestMemberType = (tmtMethods, // Generate tests for methods
  25. tmtFields, // Generate tests for fields
  26. tmtProperties // Generate tests for properties
  27. );
  28. TTestMemberTypes = set of TTestmemberType;
  29. TTestPropertyOption = (tDefault, // Generate default test for a property
  30. tGetBounds, // Generate Property GetBounds test (tiOPF)
  31. tRequired, // Generate Property Required test (tiOPF)
  32. tNotify, // Generate Property change notification test (tiOPF)
  33. tMaxLen); // Generate property MaxLen (tiOPF)
  34. TTestpropertyOptions = set of TTestpropertyOption;
  35. TTestCodeOption = (coCreateDeclaration, // Generate declaration of test cases.
  36. coImplementation, // generate (empty) implementation of tests
  37. coDefaultFail, // Insert Fail() statement in tests
  38. coSingleClass, // Use a single test class for all tests
  39. coCreateUnit, // Generate complete unit source
  40. coSetup, // Generate Setup() method for all test classes
  41. coTearDown, // Generate TearDown() method for all test classes
  42. coFunctions, // Generate tests for functions
  43. coClasses, // Generate tests for classes
  44. coRegisterTests); // Register all generated test classes
  45. TTestCodeOptions = set of TTestCodeOption;
  46. { TFPTestCodeCreator }
  47. TFPTestCodeCreator = Class(TComponent)
  48. private
  49. FCO: TTestCodeOptions;
  50. FDCT: TStrings;
  51. FDestUnitName: string;
  52. FFailMessage: String;
  53. FLimits: TStrings;
  54. FMemberTypes: TTestmemberTypes;
  55. FPO: TTestpropertyOptions;
  56. FTCP: String;
  57. FTP: String;
  58. FUTC: String;
  59. FVisibilities: TPasMemberVisibilities;
  60. FTests : TStrings;
  61. FM : String;
  62. procedure SetDCT(AValue: TStrings);
  63. procedure SetFailMessage(Const AValue: String);
  64. procedure SetLimits(AValue: TStrings);
  65. procedure StartTestClassImpl(C: TStrings; Const AClassName: String);
  66. protected
  67. // Split test name S in class name and method name.
  68. procedure ExtractClassMethod(S: string; out CN, MN: String);virtual;
  69. // Return classname for testcase for a class.
  70. Function GetTestClassName(CT : TPasClassType) : String; virtual;
  71. // Should this identifier be tested ? Only called for global identifiers.
  72. function AllowIdentifier(S: TPasElement): boolean;
  73. // Should return true if a variable/property type is a string type.
  74. function IsStringType(T: TPasType): Boolean;virtual;
  75. // Add a test to the list of tests.
  76. // If ATestClass is empty, test is added to the global unit test class.
  77. // If coSingleClass is in the options, all tests are added to this class
  78. // and ATestClass is prefixed to the test name.
  79. Procedure AddTest(Const ATestClass,ATestName : String); virtual;
  80. // Create implementation of test code. After 'Implementation' keyword was added
  81. procedure CreateImplementationCode(C: TStrings); virtual;
  82. // Add a test method body to the implementation. AddFail=True adds a Fail statement.
  83. procedure AddMethodImpl(C: TStrings; Const AClassName, AMethodName: String; AddFail: Boolean; AddInherited : Boolean = false);virtual;
  84. // Called when all the methods of a class have been emitted. Empty.
  85. procedure EndTestClassImpl(C: TStrings; Const AClassName: String);virtual;
  86. // Create interface test code. After uses clause of interface section.
  87. procedure CreateInterfaceCode(C: TStrings);virtual;
  88. // Called whenever a new test class declaration is started.
  89. procedure StartTestClassDecl(C: TStrings; AClassName: String); virtual;
  90. // Called whenever a test class declaration is finished (adds end;)
  91. procedure EndTestClassDecl(C: TStrings; AClassName: String); virtual;
  92. // Called to add default test methods for a class.
  93. procedure AddDefaultMethodDecl(C: TStrings; Const AClassName: String);virtual;
  94. // Create test code based on tests
  95. procedure CreateTestCode(Dest: TStream; const InputUnitName: string);virtual;
  96. // Calls DoCreateTests for the interface section of the module.
  97. procedure DoCreateTests(M: TPasModule);virtual;
  98. // Create tests for a modult. Creates tests for functions/procedures and classes.
  99. procedure DoCreateTests(S: TPasSection);virtual;
  100. // Called for each function/procedure in a section to create tests for it.
  101. procedure DoCreateTests(P: TPasProcedure);virtual;
  102. // Called for each overloaded function/procedure in a section to create tests for it.
  103. procedure DoCreateTests(P: TPasOverloadedProc);virtual;
  104. // Called for each class in a section to create tests for the class.
  105. procedure DoCreateTests(CT: TPasClasstype);virtual;
  106. // Called for each overloaded method in a class to create tests for it (within visibilities).
  107. procedure DoCreateTests(const TCN: String; CT: TPasClasstype; P: TPasOverloadedProc);virtual;
  108. // Called for each method in a class to create tests for it (within visibilities)
  109. procedure DoCreateTests(const TCN: String; CT: TPasClasstype; P: TPasprocedure);virtual;
  110. // Called for each field in a class to create tests for it (within visibilities).
  111. procedure DoCreateTests(const TCN: String; CT: TPasClasstype; P: TPasVariable);virtual;
  112. // Called for each property in a class to create tests for it(within visibilities).
  113. procedure DoCreateTests(const TCN: String; CT: TPasClasstype; P: TPasProperty);virtual;
  114. // Parse the actual source and return module.
  115. function ParseSource(const ASourceStream : TStream): TPasModule;
  116. // Main entry to create tests.
  117. procedure CreateTests(M: TPasModule; Dest : TStream);
  118. // List of test names in the form ClassName.MethodName. Setup and Teardown are not in the list.
  119. Property Tests : TStrings Read FTests;
  120. Public
  121. Constructor Create(AOwner :TComponent); override;
  122. Destructor Destroy; override;
  123. // Create test unit cases in dest (file/stream/tstrings) based on
  124. // Code in source
  125. Procedure Execute(Const ASourceFileName,ADestFileName : String);
  126. Procedure Execute(Const ASourceStream,ADestStream : TStream);
  127. Procedure Execute(Const ASourceCode,ADestCode : TStrings);
  128. Published
  129. // If not empty, tests will be generated only for the global identifiers in this list
  130. Property LimitIdentifiers : TStrings Read FLimits Write SetLimits;
  131. // List of names of tests which are always generated for each test.
  132. Property DefaultClassTests : TStrings Read FDCT Write SetDCT;
  133. // For class members, member visibilities for which to generate tests.
  134. Property Visibilities : TPasMemberVisibilities Read FVisibilities Write FVisibilities;
  135. // For which class members should tests be generated
  136. Property MemberTypes : TTestmemberTypes Read FMemberTypes Write FMemberTypes;
  137. // What default tests should be generated for properties/fields in a class
  138. Property PropertyOptions : TTestpropertyOptions Read FPO Write FPO;
  139. // Various options for the generated code
  140. Property CodeOptions : TTestCodeOptions Read FCO Write FCO;
  141. // Destination unit name. If empty, name will be taken from input file.
  142. Property DestUnitName : string Read FDestUnitName Write FDestUnitName;
  143. // Name for the global unit test case. If not set, it is 'Test'+the input unit name
  144. Property UnitTestClassName: String Read FUTC Write FUTC;
  145. // Prefix for names of all tests
  146. Property TestNamePrefix : String Read FTP Write FTP;
  147. // Name of parent of all test classes
  148. Property TestClassParent : String Read FTCP Write FTCP;
  149. // Text to put in Fail() statement.
  150. Property FailMessage : String Read FFailMessage Write SetFailMessage;
  151. end;
  152. Const
  153. DefaultVisibilities = [visDefault,visPublished,visPublic];
  154. DefaultPropertyOptions = [tDefault];
  155. DefaultCodeOptions = [coCreateDeclaration,coImplementation,coDefaultFail,coCreateUnit,
  156. coSetup,coTearDown, coFunctions, coClasses,
  157. coRegisterTests];
  158. DefaultMembers = [tmtMethods,tmtFields,tmtProperties];
  159. DefaultTestClassParent = 'TTestCase';
  160. Resourcestring
  161. DefaultFailmessage = 'This test is not yet implemented';
  162. Procedure CreateUnitTests(Const InputFile,OutputFile : String; ACodeOptions : TTestCodeOptions = [] );
  163. implementation
  164. Type
  165. { TTestContainer }
  166. TTestContainer = Class(TPasTreeContainer)
  167. Public
  168. function CreateElement(AClass: TPTreeElement; const AName: String;
  169. AParent: TPasElement; AVisibility: TPasMemberVisibility;
  170. const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;overload;
  171. override;
  172. function FindElement(const AName: String): TPasElement; override;
  173. end;
  174. procedure CreateUnitTests(const InputFile, OutputFile: String; ACodeOptions : TTestCodeOptions = [] );
  175. begin
  176. with TFPTestCodeCreator.Create(Nil) do
  177. try
  178. if ACodeOptions<>[] then
  179. CodeOptions:=ACodeOptions;
  180. Execute(inputfile,outputfile);
  181. finally
  182. free;
  183. end;
  184. end;
  185. { TFPTestCodeCreator }
  186. procedure TFPTestCodeCreator.SetLimits(AValue: TStrings);
  187. begin
  188. if FLimits=AValue then Exit;
  189. FLimits.Assign(AValue);
  190. end;
  191. function TFPTestCodeCreator.GetTestClassName(CT: TPasClassType): String;
  192. begin
  193. Result:=CT.Name;
  194. if Not (coSingleClass in CodeOptions) then
  195. begin
  196. if Upcase(Result[1])='T' then
  197. Delete(Result,1,1);
  198. Result:='TTest'+Result;
  199. end;
  200. end;
  201. procedure TFPTestCodeCreator.EndTestClassDecl(C: TStrings; AClassName: String);
  202. begin
  203. C.Add(' end;');
  204. C.Add('');
  205. C.Add('');
  206. end;
  207. procedure TFPTestCodeCreator.AddTest(const ATestClass, ATestName: String);
  208. Var
  209. CN,TN : String;
  210. begin
  211. TN:=ATestName;
  212. if ATestClass='' then
  213. CN:=UnitTestClassName
  214. else
  215. CN:=ATestClass;
  216. if (coSingleClass in CodeOptions) then
  217. begin
  218. TN:=ATestClass+TN;
  219. CN:=UnitTestClassName;
  220. end;
  221. FTests.Add(CN+'.'+TestNamePrefix+TN);
  222. end;
  223. procedure TFPTestCodeCreator.DoCreateTests(const TCN: String;
  224. CT: TPasClasstype; P: TPasOverloadedProc);
  225. begin
  226. AddTest(TCN,P.Name);
  227. end;
  228. procedure TFPTestCodeCreator.DoCreateTests(P : TPasProcedure);
  229. begin
  230. AddTest('',P.Name);
  231. end;
  232. procedure TFPTestCodeCreator.DoCreateTests(P: TPasOverloadedProc);
  233. begin
  234. AddTest('',P.Name);
  235. end;
  236. procedure TFPTestCodeCreator.DoCreateTests(Const TCN: String; CT : TPasClasstype; P : TPasprocedure);
  237. begin
  238. AddTest(TCN,P.Name);
  239. end;
  240. Function TFPTestCodeCreator.IsStringType(T : TPasType) : Boolean;
  241. Var
  242. tn : string;
  243. begin
  244. While t is TPasAliasType do
  245. T:=TPasAliasType(t).DestType;
  246. tn:=lowercase(t.name);
  247. Result:=(T is TPasStringType) or (tn='string') or (tn='ansistring') or (tn='widestring') or (tn='unicodestring') or (tn='shortstring');
  248. end;
  249. procedure TFPTestCodeCreator.DoCreateTests(Const TCN: String; CT : TPasClasstype; P : TPasVariable);
  250. begin
  251. if (tDefault in PropertyOptions) then
  252. AddTest(TCN,P.Name);
  253. if (tRequired in PropertyOptions) then
  254. AddTest(TCN,P.Name+'Required');
  255. if (tGetBounds in PropertyOptions) then
  256. AddTest(TCN,P.Name+'GetBounds');
  257. If (tmaxLen in PropertyOptions) then
  258. if Assigned(P.VarType) and IsStringType(P.VarType) then
  259. AddTest(TCN,P.Name+'MaxLen');
  260. end;
  261. procedure TFPTestCodeCreator.DoCreateTests(const TCN: String;
  262. CT: TPasClasstype; P: TPasProperty);
  263. begin
  264. if (tDefault in PropertyOptions) then
  265. AddTest(TCN,P.Name);
  266. if (tRequired in PropertyOptions) then
  267. AddTest(TCN,P.Name+'Required');
  268. if (tGetBounds in PropertyOptions) then
  269. AddTest(TCN,P.Name+'GetBounds');
  270. if (tNotify in PropertyOptions) then
  271. AddTest(TCN,P.Name+'Notify');
  272. If (tmaxLen in PropertyOptions) then
  273. if Assigned(P.VarType) and IsStringType(P.VarType) then
  274. AddTest(TCN,P.Name+'MaxLen');
  275. end;
  276. procedure TFPTestCodeCreator.DoCreateTests(CT : TPasClasstype);
  277. Var
  278. E : TPasElement;
  279. I : Integer;
  280. TCN : String;
  281. begin
  282. TCN:=GetTestClassName(CT);
  283. For I:=0 to DefaultClassTests.Count-1 do
  284. AddTest(TCN,DefaultClassTests[i]);
  285. if (tmtMethods in Membertypes) then
  286. For I:=0 to CT.Members.Count-1 do
  287. begin
  288. E:=TPasElement(CT.Members[i]);
  289. if (E is TPasProcedure) and (E.Visibility in Visibilities) then
  290. DoCreateTests(TCN,CT,TPasProcedure(E))
  291. else if (E is TPasoverloadedProc) and (E.Visibility in Visibilities) then
  292. DoCreateTests(TCN,CT,TPasoverloadedProc(E));
  293. end;
  294. if (tmtFields in Membertypes) then
  295. For I:=0 to CT.Members.Count-1 do
  296. begin
  297. E:=TPasElement(CT.Members[i]);
  298. if (E is TPasVariable) and (Not(E is TPasProperty)) and (E.Visibility in Visibilities) then
  299. DoCreateTests(TCN,CT,TPasVariable(E));
  300. end;
  301. if (tmtProperties in Membertypes) then
  302. For I:=0 to CT.Members.Count-1 do
  303. begin
  304. E:=TPasElement(CT.Members[i]);
  305. if (E is TPasProperty) and (E.Visibility in Visibilities) then
  306. DoCreateTests(TCN,CT,TPasProperty(E));
  307. end;
  308. end;
  309. function TFPTestCodeCreator.AllowIdentifier(S: TPasElement) : boolean;
  310. begin
  311. Result:=(LimitIdentifiers.Count=0) or (LimitIdentifiers.IndexOf(S.Name)<>-1);
  312. end;
  313. procedure TFPTestCodeCreator.DoCreateTests(S: TPasSection);
  314. Var
  315. I : integer;
  316. CT : TPasClasstype;
  317. FT : TPasProcedure;
  318. O : TPasOverloadedProc;
  319. begin
  320. if coClasses in CodeOptions then
  321. For I:=0 to S.Classes.Count-1 do
  322. begin
  323. CT:=TPasClassType(S.Classes[i]);
  324. If Not CT.IsForward then
  325. if AllowIdentifier(CT) then
  326. DoCreateTests(CT);
  327. end;
  328. if coFunctions in CodeOptions then
  329. For I:=0 to S.Functions.Count-1 do
  330. begin
  331. if TPasElement(S.Functions[i]) is TPasProcedure then
  332. begin
  333. FT:=TPasElement(S.Functions[i]) as TPasProcedure;
  334. If Not FT.IsForward then
  335. if AllowIdentifier(FT) then
  336. DoCreateTests(FT);
  337. end
  338. else if TPasElement(S.Functions[i]) is TPasOverloadedProc then
  339. begin
  340. O:=TPasElement(S.Functions[i]) as TPasOverloadedProc;
  341. if AllowIdentifier(O) then
  342. DoCreateTests(O);
  343. end;
  344. end;
  345. end;
  346. procedure TFPTestCodeCreator.DoCreateTests(M: TPasModule);
  347. begin
  348. If UnitTestClassName='' then
  349. UnitTestClassName:='Test'+M.Name;
  350. DoCreateTests(M.InterfaceSection);
  351. end;
  352. procedure TFPTestCodeCreator.SetDCT(AValue: TStrings);
  353. begin
  354. if FDCT=AValue then Exit;
  355. FDCT.Assign(AValue);
  356. end;
  357. procedure TFPTestCodeCreator.SetFailMessage(Const AValue: String);
  358. begin
  359. if FFailMessage=AValue then Exit;
  360. FFailMessage:=AValue;
  361. FM:=StringReplace(FailMessage,'''','''''',[rfReplaceAll]);
  362. end;
  363. constructor TFPTestCodeCreator.Create(AOwner: TComponent);
  364. begin
  365. inherited Create(AOwner);
  366. FLimits:=TStringList.Create;
  367. TStringList(FLimits).Sorted:=True;
  368. FDCT:=TstringList.Create;
  369. FDCT.Add('Empty');
  370. FDCT.Add('IsValid');
  371. TestNamePrefix:='Test';
  372. Visibilities:=DefaultVisibilities;
  373. CodeOptions:=DefaultCodeOptions;
  374. PropertyOptions:=DefaultPropertyOptions;
  375. MemberTypes:=DefaultMembers;
  376. TestClassParent:=DefaultTestClassParent;
  377. FailMessage:=DefaultFailmessage;
  378. end;
  379. destructor TFPTestCodeCreator.Destroy;
  380. begin
  381. FreeAndNil(FDCT);
  382. FreeAndNil(FLimits);
  383. inherited Destroy;
  384. end;
  385. procedure TFPTestCodeCreator.Execute(const ASourceFileName,
  386. ADestFileName: String);
  387. Var
  388. Fi,Fo : TFileStream;
  389. begin
  390. Fi:=TFileStream.Create(ASourceFileName,fmOpenRead);
  391. try
  392. Fo:=TFileStream.Create(ADestFileName,fmCreate);
  393. try
  394. if (DestunitName='') then
  395. DestUnitName:=ChangeFileExt(ExtractFileName(ADestFileName),'');
  396. Execute(Fi,Fo);
  397. finally
  398. FO.free;
  399. end;
  400. finally
  401. Fi.Free;
  402. end;
  403. end;
  404. procedure TFPTestCodeCreator.StartTestClassDecl(C : TStrings; AClassName : String);
  405. begin
  406. C.Add(' { '+AClassName+' }');
  407. C.Add('');
  408. C.Add(Format(' %s = Class(%s)',[ACLassName,TestClassParent]));
  409. If (([coSetup,coTearDown] * CodeOptions)<>[]) then
  410. begin
  411. C.Add(' Protected');
  412. if coSetup in CodeOptions then
  413. C.Add(' procedure Setup; override;');
  414. if coSetup in CodeOptions then
  415. C.Add(' procedure TearDown; override;');
  416. end;
  417. end;
  418. procedure TFPTestCodeCreator.AddDefaultMethodDecl(C : TStrings; const AClassName : String);
  419. begin
  420. //
  421. end;
  422. Procedure TFPTestCodeCreator.ExtractClassMethod(S : string; Out CN,MN : String);
  423. Var
  424. P : Integer;
  425. begin
  426. P:=Pos('.',S);
  427. Cn:=Copy(S,1,P-1);
  428. MN:=S;
  429. Delete(MN,1,P);
  430. end;
  431. procedure TFPTestCodeCreator.CreateInterfaceCode(C : TStrings);
  432. Var
  433. CCN,CN,MN : String;
  434. I : Integer;
  435. begin
  436. CCN:='';
  437. For I:=0 to FTests.Count-1 do
  438. begin
  439. ExtractClassMethod(FTests[i],Cn,MN);
  440. If (CN<>CCN) then
  441. begin
  442. if (CCN<>'') then
  443. EndTestClassDecl(C,CN);
  444. StartTestClassDecl(C,CN);
  445. C.Add(' Published');
  446. AddDefaultMethodDecl(C,CN);
  447. CCN:=CN;
  448. end;
  449. C.Add(' Procedure '+MN+';');
  450. end;
  451. if (CCN<>'') then
  452. EndTestClassDecl(C,CN);
  453. end;
  454. procedure TFPTestCodeCreator.AddMethodImpl(C : TStrings; Const AClassName,AMethodName : String; AddFail : Boolean; AddInherited : Boolean = false);
  455. begin
  456. C.Add('');
  457. C.Add(Format('Procedure %s.%s;',[AClassName,AMethodName]));
  458. C.Add('');
  459. C.Add('begin');
  460. if AddFail then
  461. C.Add(Format(' Fail(''%s'');',[FM]));
  462. if AddInherited then
  463. C.Add(' Inherited;');
  464. C.Add('end;');
  465. C.Add('');
  466. end;
  467. procedure TFPTestCodeCreator.StartTestClassImpl(C : TStrings; Const AClassName : String);
  468. begin
  469. C.Add('');
  470. C.Add(' { '+AClassName+' }');
  471. C.Add('');
  472. if coSetup in CodeOptions then
  473. AddMethodImpl(C,AClassName,'Setup',False,True);
  474. if coTearDown in CodeOptions then
  475. AddMethodImpl(C,AClassName,'TearDown',False,True);
  476. end;
  477. procedure TFPTestCodeCreator.EndTestClassImpl(C : TStrings; Const AClassName : String);
  478. begin
  479. end;
  480. procedure TFPTestCodeCreator.CreateImplementationCode(C : TStrings);
  481. Var
  482. CCN,CN,MN : String;
  483. I : Integer;
  484. F : Boolean;
  485. begin
  486. CCN:='';
  487. F:=coDefaultFail in CodeOptions;
  488. For I:=0 to FTests.Count-1 do
  489. begin
  490. ExtractClassMethod(FTests[i],Cn,MN);
  491. If (CN<>CCN) then
  492. begin
  493. if (CCN<>'') then
  494. EndTestClassImpl(C,CN);
  495. StartTestClassImpl(C,CN);
  496. CCN:=CN;
  497. end;
  498. AddMethodImpl(C,CN,MN,F);
  499. end;
  500. if (CCN<>'') then
  501. EndTestClassImpl(C,CN);
  502. end;
  503. procedure TFPTestCodeCreator.CreateTestCode(Dest : TStream; Const InputUnitName : string);
  504. Function GetTestClassNames : String;
  505. Var
  506. L : TStringList;
  507. i : Integer;
  508. CN,MN : String;
  509. begin
  510. L:=TStringList.Create;
  511. try
  512. L.Sorted:=True;
  513. L.Duplicates:=dupIgnore;
  514. For I:=0 to Tests.Count-1 do
  515. begin
  516. Self.ExtractClassMethod(Tests[i],CN,MN);
  517. L.Add(CN);
  518. end;
  519. Result:=L.CommaText;
  520. finally
  521. L.free;
  522. end;
  523. end;
  524. Var
  525. C : TStrings;
  526. S : String;
  527. begin
  528. C:=TStringList.Create;
  529. try
  530. If (coCreateUnit in CodeOptions) then
  531. begin
  532. C.Add(Format('unit %s;',[DestUnitName]));
  533. C.Add('');
  534. C.Add('interface');
  535. C.Add('');
  536. C.Add(Format('Uses Classes, SysUtils, fpcunit, testutils, testregistry, %s;',[InputUnitName]));
  537. C.Add('');
  538. C.Add('Type');
  539. end;
  540. If (coCreateDeclaration in CodeOptions) then
  541. CreateInterfaceCode(C);
  542. if (coImplementation in CodeOptions) then
  543. begin
  544. If (coCreateUnit in CodeOptions) then
  545. begin
  546. C.Add('');
  547. C.Add('implementation');
  548. C.Add('');
  549. end;
  550. CreateImplementationCode(C);
  551. If (coCreateUnit in CodeOptions) then
  552. begin
  553. C.Add('');
  554. if coRegisterTests in CodeOptions then
  555. begin
  556. S:=GetTestClassNames;
  557. C.Add('Initialization');
  558. C.Add(Format(' RegisterTests([%s]);',[S]));
  559. end;
  560. C.Add('end.');
  561. end;
  562. end;
  563. C.SaveToStream(Dest);
  564. finally
  565. C.Free;
  566. end;
  567. end;
  568. procedure TFPTestCodeCreator.CreateTests(M: TPasModule; Dest: TStream);
  569. begin
  570. FTests:=TStringList.Create;
  571. try
  572. DoCreateTests(M);
  573. CreateTestCode(Dest,M.Name);
  574. finally
  575. FTests.Free;
  576. end;
  577. end;
  578. Function TFPTestCodeCreator.ParseSource(const ASourceStream : TStream) : TPasModule;
  579. Var
  580. R : TStreamResolver;
  581. S : TPascalScanner;
  582. P : TPasParser;
  583. M : TPasModule;
  584. C : TTestContainer;
  585. begin
  586. R:=TStreamResolver.Create;
  587. try
  588. R.AddStream('file.pp',ASourceStream);
  589. S:=TPascalScanner.Create(R);
  590. try
  591. S.OpenFile('file.pp');
  592. C:=TTestContainer.Create;
  593. try
  594. C.InterfaceOnly:=True;
  595. P:=TPasParser.Create(S,R,C);
  596. try
  597. P.ParseMain(Result);
  598. finally
  599. P.Free;
  600. end;
  601. finally
  602. C.Free;
  603. end;
  604. finally
  605. S.Free;
  606. end;
  607. finally
  608. R.Free;
  609. end;
  610. end;
  611. procedure TFPTestCodeCreator.Execute(const ASourceStream, ADestStream: TStream);
  612. Var
  613. M : TPasModule;
  614. begin
  615. M:=ParseSource(ASourceStream);
  616. try
  617. if Assigned(M) then
  618. CreateTests(M,ADestStream);
  619. finally
  620. M.Free;
  621. end;
  622. end;
  623. procedure TFPTestCodeCreator.Execute(const ASourceCode, ADestCode: TStrings);
  624. Var
  625. MIn,Mout : TStringStream;
  626. begin
  627. Min:=TStringStream.Create(ASourceCode.Text);
  628. try
  629. Mout:=TStringstream.Create('');
  630. try
  631. Min.Position:=0;
  632. Execute(Min,Mout);
  633. Mout.Position:=0;
  634. ADestCode.Text:=Mout.DataString;
  635. finally
  636. Mout.free;
  637. end;
  638. finally
  639. Min.Free;
  640. end;
  641. end;
  642. { TTestContainer }
  643. function TTestContainer.CreateElement(AClass: TPTreeElement;
  644. const AName: String; AParent: TPasElement; AVisibility: TPasMemberVisibility;
  645. const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;
  646. begin
  647. Result:=AClass.Create(AName,AParent);
  648. FOwnedElements.Add(Result);
  649. Result.Visibility:=AVisibility;
  650. Result.SourceFilename:=ASourceFileName;
  651. Result.SourceLinenumber:=ASourceLineNumber;
  652. end;
  653. function TTestContainer.FindElement(const AName: String): TPasElement;
  654. begin
  655. Result:=Nil;
  656. end;
  657. end.