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

  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