/packages/fcl-passrc/src/pastounittest.pp

https://github.com/slibre/freepascal · Puppet · 745 lines · 649 code · 96 blank · 0 comment · 86 complexity · dbee06168ffac3a67fe1c5b834c11484 MD5 · raw file

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