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