reports/Builder__TestReport.st
author Claus Gittinger <cg@exept.de>
Thu, 28 Mar 2019 13:54:38 +0100
changeset 542 aa25a71be62a
parent 251 cb6ebbd8d1c0
child 303 e217bb7aacf4
permissions -rw-r--r--
#DOCUMENTATION by cg
class: stx_goodies_builder_quickSelfTest
class definition

class: stx_goodies_builder_quickSelfTest class
added:18 methods
     1 "{ Package: 'stx:goodies/builder/reports' }"
     2 
     3 "{ NameSpace: Builder }"
     4 
     5 Report subclass:#TestReport
     6 	instanceVariableNames:'suite coverage instrument keepStdout'
     7 	classVariableNames:''
     8 	poolDictionaries:''
     9 	category:'Builder-Reports'
    10 !
    11 
    12 TestResult subclass:#Result
    13 	instanceVariableNames:'format time npassed nfailed nerror nskipped collector'
    14 	classVariableNames:''
    15 	poolDictionaries:''
    16 	privateIn:TestReport
    17 !
    18 
    19 
    20 !TestReport methodsFor:'accessing'!
    21 
    22 keepStdout
    23     ^ keepStdout
    24 !
    25 
    26 keepStdout:aBoolean
    27     keepStdout := aBoolean.
    28 !
    29 
    30 suite
    31     ^ suite
    32 
    33     "Created: / 07-11-2011 / 09:41:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    34 ! !
    35 
    36 !TestReport methodsFor:'accessing - defaults'!
    37 
    38 defaultFileSuffix
    39 
    40     ^'Test'
    41 
    42     "Created: / 04-08-2011 / 12:56:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    43 !
    44 
    45 defaultFormat
    46     "superclass HDReport says that I am responsible to implement this method"
    47 
    48     ^ Builder::TestReportFormat::JUnit new
    49 
    50     "Created: / 04-08-2011 / 11:54:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    51 !
    52 
    53 defaultName
    54 
    55     ^String streamContents:[:s|
    56         suite tests do:[:suite|
    57             s nextPutAll: suite name
    58         ] separatedBy:[
    59             s nextPut:$,;space
    60         ]
    61     ]
    62 
    63     "Created: / 07-11-2011 / 09:47:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    64 ! !
    65 
    66 !TestReport methodsFor:'command line options'!
    67 
    68 cmdlineOptionCoverage
    69 
    70     ^CmdLineOption new
    71         short: $c;
    72         long: 'coverage';
    73         description: 'collect code coverage when running tests';
    74         action:[
    75             coverage := CoverageReport new.
    76         ]
    77 
    78     "Created: / 25-06-2013 / 15:36:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    79     "Modified: / 27-05-2014 / 16:54:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    80 !
    81 
    82 cmdlineOptionDropStdout
    83 
    84     ^CmdLineOption new
    85         long: 'drop-stdout';
    86         description: 'Do not include stdout in report';
    87         action:[
    88             keepStdout := false
    89         ]
    90 
    91     "Created: / 08-08-2014 / 11:48:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    92 !
    93 
    94 cmdlineOptionInstrument
    95 
    96     ^CmdLineOption new
    97         short: $I;
    98         long: 'instrument';
    99         description: 'extra package to instrument for coverage (implies --coverage)';
   100         action:[:package |
   101             instrument isNil ifTrue:[ 
   102                 instrument := Set new.
   103             ].
   104             instrument add: package.
   105             coverage isNil ifTrue:[ 
   106                 coverage := CoverageReport new.
   107             ].
   108 
   109         ]
   110 
   111     "Created: / 27-05-2014 / 16:34:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   112 !
   113 
   114 cmdlineOptionKeepStdout
   115 
   116     ^CmdLineOption new
   117         long: 'keep-stdout';
   118         description: 'Keep stdout and include it in report (may generate huge report!!)';
   119         action:[
   120             keepStdout := true
   121         ]
   122 
   123     "Created: / 16-06-2014 / 10:42:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   124 ! !
   125 
   126 !TestReport methodsFor:'initialization'!
   127 
   128 initialize
   129 
   130     suite := TestSuite new.
   131     coverage := nil.
   132     keepStdout := true.
   133 
   134     "Modified: / 08-08-2014 / 11:45:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   135 !
   136 
   137 setupForClasses:classes
   138     "Setup the report to run given classes"
   139 
   140     | suiteFromClasses |
   141 
   142     suiteFromClasses := TestSuite named:name.
   143     classes do:
   144             [:cls | 
   145             |tc|
   146 
   147             cls isTestCaseLike 
   148                 ifTrue:
   149                     [ tc := cls asTestCase.
   150                     tc isAbstract ifFalse:[ suiteFromClasses addTest:tc suite ] ] ].
   151 
   152     self setupForSuite: suiteFromClasses.
   153 
   154     "Created: / 04-08-2011 / 14:34:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   155 !
   156 
   157 setupForPackages:pkgs 
   158 
   159     pkgs do: [:pkg | 
   160         |def |
   161 
   162         self loadPackageIfNotAlready: pkg.
   163         def := ProjectDefinition definitionClassForPackage:pkg.
   164 
   165         (def respondsTo:#testSuite) ifTrue:[ 
   166             suite addTest:def testSuite 
   167         ] ifFalse:[ 
   168             | classes psuite |
   169             psuite := TestSuite named:pkg.
   170 
   171             classes := def notNil 
   172                         ifTrue:[ def classes ]
   173                         ifFalse:[ ProjectDefinition searchForClassesWithProject:pkg asSymbol ].
   174             classes do: [:cls | 
   175                 |tc|
   176 
   177                 cls isTestCaseLike ifTrue: [ 
   178                     tc := cls asTestCase.
   179                     tc isAbstract ifFalse:[ 
   180                         psuite addTest:tc suite
   181                     ]
   182                 ]
   183             ].
   184             suite addTest: psuite.
   185         ]
   186     ].
   187     coverage notNil ifTrue:[
   188         coverage setupForPackages: packages.
   189         instrument notNil ifTrue:[ 
   190             coverage setupForPackages: instrument.
   191         ].
   192     ]
   193 
   194     "Modified: / 27-05-2014 / 16:35:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   195 !
   196 
   197 setupForSuite: suiteToAdd
   198 
   199     suite addTest: suiteToAdd.
   200 
   201     "Created: / 06-11-2011 / 18:27:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   202 ! !
   203 
   204 !TestReport methodsFor:'private'!
   205 
   206 print: anObject on: aStream
   207 
   208     [ anObject printOn: aStream ]
   209         on: Error do:
   210             [aStream 
   211                 nextPutAll: '** error when prining instance of ';
   212                 nextPutAll: anObject class name;
   213                 nextPutAll: '**']
   214 
   215     "Created: / 15-03-2011 / 22:09:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   216 ! !
   217 
   218 !TestReport methodsFor:'running'!
   219 
   220 runReport
   221 
   222     | result |
   223     result := Result new format:format.
   224     coverage notNil ifTrue:[
   225         InstrumentationContext  run:[
   226             suite run:result.
   227         ].
   228         Transcript cr; cr.
   229         Transcript show: 'COLLECTING COVERAGE...'.
   230         coverage name: self name.
   231         coverage run.
   232     ] ifFalse:[
   233         suite run:result.
   234     ].
   235     Transcript cr; cr.
   236 
   237     result failureOutcomes do:[:failureOutcome |
   238         Transcript show: 'FAILED '.
   239         failureOutcome testCase printOn: Transcript.
   240         Transcript cr.
   241     ].
   242     result errorOutcomes do:[:errorOutcome |
   243         Transcript show: 'ERROR  '.
   244         errorOutcome testCase printOn: Transcript.
   245         Transcript cr.
   246     ].
   247     Transcript cr; cr.
   248     Transcript show: 'SUMMARY: '.
   249     result printOn: Transcript.
   250     Transcript cr.
   251 
   252     "Created: / 04-08-2011 / 12:39:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   253     "Modified: / 23-10-2013 / 11:48:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   254 ! !
   255 
   256 !TestReport::Result methodsFor:'accessing'!
   257 
   258 errorCount
   259 
   260     ^nerror
   261 
   262     "Created: / 31-01-2013 / 13:54:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   263 !
   264 
   265 exceptions
   266 
   267     ^super exceptions , HaltInterrupt
   268 
   269     "Created: / 03-08-2011 / 14:59:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   270 !
   271 
   272 failureCount
   273 
   274     ^nfailed
   275 
   276     "Created: / 31-01-2013 / 13:53:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   277 !
   278 
   279 format
   280     ^ format
   281 !
   282 
   283 format:aFormat
   284     format := aFormat.
   285 !
   286 
   287 passedCount
   288 
   289     ^npassed
   290 
   291     "Created: / 31-01-2013 / 13:54:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   292 !
   293 
   294 skippedCount
   295 
   296     ^nskipped
   297 
   298     "Created: / 31-01-2013 / 13:54:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   299 ! !
   300 
   301 !TestReport::Result methodsFor:'adding'!
   302 
   303 addError: testcase detail: exception
   304 
   305     outcome result: (TestResult stateError).
   306     outcome collectedOutput: collector contents. 
   307     format writeTestCase: testcase outcome: outcome time: time exception: exception.
   308     Transcript show:'...ERROR'.
   309     Logger trace: 'Finised %1>>%2, result ERROR' with: testcase nameForHDTestReport with: testcase selectorForHDTestReport.
   310     self errorOutcomes add:outcome.      
   311     nerror := nerror + 1.
   312 
   313     "Created: / 03-08-2011 / 15:00:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   314     "Modified: / 29-10-2014 / 14:02:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   315 !
   316 
   317 addFailure: testcase detail: exception
   318 
   319     outcome result: (TestResult stateFail).
   320     outcome collectedOutput: collector contents. 
   321     format writeTestCase: testcase outcome: outcome time: time exception: exception.
   322     Transcript show:'...FAILED'.
   323     Logger trace: 'Finised %1>>%2, result FAILED' with: testcase nameForHDTestReport with: testcase selectorForHDTestReport.
   324     self failureOutcomes add: outcome.
   325     nfailed := nfailed + 1.
   326 
   327     "Created: / 03-08-2011 / 15:00:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   328     "Modified: / 29-10-2014 / 14:01:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   329 !
   330 
   331 addPass: testcase
   332 
   333     outcome result: TestResult statePass.
   334     format writeTestCase: testcase outcome: outcome time: time exception: nil.
   335     Transcript show:'...OK'.
   336     Logger trace: 'Finised %1>>%2, result PASSED' with: testcase nameForHDTestReport with: testcase selectorForHDTestReport.
   337     npassed := npassed + 1.
   338 
   339     "Created: / 03-08-2011 / 15:19:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   340     "Modified: / 29-10-2014 / 14:01:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   341 !
   342 
   343 addSkipped: testcase
   344 
   345     outcome := self createOutcome.
   346     outcome testCase: testcase.        
   347     outcome result: TestResult stateSkip.
   348     format writeTestCase: testcase outcome: outcome time: time exception: nil.
   349     Transcript show:'...SKIPPED'.
   350     Logger trace: 'Finised %1>>%2, result SKIPPED' with: testcase nameForHDTestReport with: testcase selectorForHDTestReport.
   351     nskipped := nskipped + 1.
   352 
   353     "Created: / 21-11-2012 / 15:35:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   354     "Modified: / 29-10-2014 / 14:01:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   355 ! !
   356 
   357 !TestReport::Result methodsFor:'initialization'!
   358 
   359 initialize
   360     super initialize.
   361 
   362     npassed := nfailed := nerror := nskipped := 0
   363 
   364     "Created: / 31-01-2013 / 13:52:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   365 ! !
   366 
   367 !TestReport::Result methodsFor:'running'!
   368 
   369 performCase:aTestCase 
   370     | savedStdout savedStderr savedTranscript encoder |
   371 
   372     savedStdout := Stdout.
   373     savedStderr := Stdout.
   374     savedTranscript := Transcript.
   375     encoder := OperatingSystem isMSWINDOWSlike 
   376                 ifTrue:[ CharacterEncoder encoderForUTF8 ]
   377                 ifFalse:[ CharacterEncoder encoderFor: OperatingSystem getCodeset ].
   378     collector := WriteStream on:(String new:100).
   379     [
   380         Stdout := SplittingWriteStream on:collector and: (EncodedStream stream: Stdout encoder: encoder).
   381         Stderr := SplittingWriteStream on:collector and: (EncodedStream stream: Stderr encoder: encoder).
   382         Transcript := SplittingWriteStream on:collector and: Transcript.
   383         time := Time millisecondsToRun: [ super performCase: aTestCase ]
   384     ] ensure:[
   385         Stdout := savedStdout.
   386         Stderr := savedStderr.
   387         Transcript := savedTranscript.
   388         outcome collectedOutput: nil. "/ flush it, it has been written to output already
   389         collector := nil.
   390     ].
   391 
   392     "Created: / 03-08-2011 / 18:40:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   393     "Modified: / 07-12-2014 / 01:12:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   394 !
   395 
   396 runCase:aTestCase debugged: debugged 
   397 
   398     | timeout |
   399     timeout := aTestCase timeout.
   400 
   401     self runCase: aTestCase debugged: debugged 
   402          fork:  (aTestCase shouldFork or:[timeout notNil])
   403          timeout: timeout ? 60"sec"
   404 
   405     "Created: / 22-08-2011 / 14:37:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   406 !
   407 
   408 runCase:aTestCase debugged: debugged fork:doFork
   409 
   410     ^self runCase:aTestCase debugged: debugged 
   411           fork:doFork timeout: aTestCase timeout ? 60"sec"
   412 
   413     "Created: / 22-08-2011 / 14:38:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   414 !
   415 
   416 runCase:aTestCase debugged: debugged fork:doFork timeout: tout
   417     | nm sel |
   418 
   419     (aTestCase perform: #shouldSkip ifNotUnderstood:[false]) ifTrue:[
   420         self addSkipped: aTestCase.
   421         ^self.
   422     ].
   423 
   424     nm := aTestCase nameForHDTestReport.
   425     nm size > 20 ifTrue:[
   426         nm := (nm copyTo: 17) , '...'
   427     ].
   428     sel := aTestCase selectorForHDTestReport.
   429     sel size > 20 ifTrue:[
   430         sel := '...' , (sel copyFrom: sel size - 16 to: sel size)
   431     ].
   432     Transcript showCR:('%1 >> #%2' bindWith: aTestCase nameForHDTestReport with: aTestCase selectorForHDTestReport).
   433     Transcript show:('%-20s >> %-20s : ' printfWith: nm with: sel).
   434 
   435     outcome := self createOutcome.
   436     outcome testCase: aTestCase.
   437 
   438     doFork ifFalse:[ 
   439         super runCase:aTestCase debugged: debugged.
   440         Transcript cr.
   441         ^self.
   442     ].
   443 
   444     OperatingSystem isUNIXlike ifTrue:[
   445 "/        self unixForkCase: aTestCase debugged: debugged.
   446 "/      Use lightweight forking
   447         self lightForkCase: aTestCase debugged: debugged timeout: tout.
   448         ^ self.
   449     ].
   450     OperatingSystem isMSWINDOWSlike ifTrue:[
   451         self lightForkCase: aTestCase debugged: debugged timeout: tout.
   452         ^ self.
   453     ].
   454 
   455     self error:'Unssuported platform'
   456 
   457     "Created: / 12-01-2012 / 17:52:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   458     "Modified: / 29-10-2014 / 13:57:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   459 ! !
   460 
   461 !TestReport::Result methodsFor:'running-private'!
   462 
   463 lightForkCase:aTestCase debugged: debugged timeout: timeout
   464     | thread sema stime etime timeouted error stack log logPos |
   465 
   466     Logger trace: 'Running %1>>%2' with: aTestCase nameForHDTestReport with: aTestCase selectorForHDTestReport.
   467     Transcript show:'F'.
   468     sema := Semaphore new.
   469     stime := OperatingSystem getMillisecondTime.
   470     log := false.
   471     logPos := format stream stream position.
   472     timeouted := false.
   473     thread := [ super runCase:aTestCase debugged: debugged ] newProcess.
   474     thread addExitAction:[sema signal].
   475     thread name: ('Testcase execution thread (%1)' bindWith: aTestCase).
   476     thread resume.
   477 
   478     Transcript show: 'W'.
   479     (sema waitWithTimeout:timeout) isNil ifTrue: [
   480         Transcript show: 'T'.
   481         stack := String streamContents:[:s |  ReportRunner dumpProcessesOn:s ].
   482         thread terminate.
   483         timeouted := true.
   484         Transcript show: 'K'.
   485     ].
   486 
   487     etime := OperatingSystem getMillisecondTime.
   488     timeouted ifTrue:[
   489         error := TimeoutError new messageText: 'Timed out'.
   490         outcome result: TestResult stateError.
   491         format 
   492             writeTestCase: aTestCase outcome: outcome 
   493                      time: etime - stime
   494                 exception: error
   495                stacktrace: stack.
   496          Transcript show:'...ERROR'.
   497          Logger trace: 'Finised %1>>%2, result ERROR (timeout)' with: aTestCase nameForHDTestReport with: aTestCase selectorForHDTestReport.
   498     ].
   499 
   500     outcome := nil.
   501     Transcript cr.
   502 
   503     "Created: / 12-01-2012 / 17:42:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   504     "Modified: / 29-10-2014 / 13:59:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   505 !
   506 
   507 unixForkCase:aTestCase debugged: debugged timeout: timeout
   508     | pid status sema stime etime error stack suiteFailuresBefore suiteErrorsBefore log logPos |
   509 
   510     Transcript show:'forking...'.
   511     sema := Semaphore new.
   512     stime := OperatingSystem getMillisecondTime.
   513     log := false.
   514     logPos := format stream stream position.
   515     Processor monitor:
   516             [ pid := OperatingSystem fork.
   517             pid == 0 ifTrue:[ nil ] ifFalse:[ pid ] ]
   518         action:
   519             [:s | 
   520             Transcript show:'child finished...'.
   521             status := s.
   522             sema signal ].
   523     pid == 0 
   524         ifTrue:
   525             [ "Child, exit codes:
   526              0...PASSED
   527              1...FAILED
   528              2...ERROR
   529            >64...got signal <code>-64"
   530             
   531             [ suiteFailuresBefore := failures.
   532             suiteErrorsBefore := errors.
   533             super runCase:aTestCase debugged: debugged.
   534             suiteErrorsBefore ~~ errors ifTrue:[ Smalltalk exit:2 ].
   535             suiteFailuresBefore ~~ failures ifTrue:[ Smalltalk exit:1 ].
   536             format streamClose.
   537             Smalltalk exit:0. ] on:OSSignalInterrupt
   538                     do:[:ex | format streamClose. Smalltalk exit:64 + ex parameter ] ]
   539         ifFalse:
   540             [ "Parent"
   541             format streamClose.
   542             Transcript show: 'waiting for child...'.
   543             (sema waitWithTimeout:timeout) isNil 
   544                 ifTrue:
   545                     [Transcript show: 'timeout...'.
   546                     OperatingSystem terminateProcess:pid.
   547                     OperatingSystem childProcessWait:true pid:pid.
   548                     Transcript show: 'killed...'.
   549                     ].
   550             etime := OperatingSystem getMillisecondTime.
   551             (status isNil or:[ status success not ]) 
   552                 ifFalse:[
   553                     "/child finished, result is pass. However, it is not in my passed collection
   554                     "/since addPass: has been called in child process
   555                    super addPass: aTestCase.
   556                 ] ifTrue:
   557                     [ log := true.
   558                     status isNil 
   559                         ifTrue:
   560                             [ error := TimeoutError new parameter:timeout.
   561                             stack := 'Oops, timed out!! (timeout was ' , timeout printString , ' sec)'. ]
   562                         ifFalse:
   563                             [ status status == #signal 
   564                                 ifTrue:
   565                                     [ error := OSSignalInterrupt new parameter:status code.
   566                                     stack := 'Oops, VM terminated on signal ' , status code printString, ' (stactrace not awailable)' ].
   567                             status status == #exit 
   568                                 ifTrue:
   569                                     [ status code == 1 
   570                                         ifTrue:
   571                                             [super addFailure: aTestCase detail: nil.
   572                                             log := false ].
   573                                     status code == 2 
   574                                         ifTrue:
   575                                             [super addError: aTestCase detail: nil.
   576                                             log := false ].
   577                                     status code > 64 
   578                                         ifTrue:
   579                                             [ error := OSSignalInterrupt new parameter:status code - 64.
   580                                             stack := 'Oops, VM terminated on signal ' , status code p ] ] ]. ].
   581             format streamOpenForAppend.
   582             log ifTrue:[
   583                      outcome result: TestResult stateError.
   584                      format stream stream position: logPos.
   585                      format 
   586                         writeTestCase: aTestCase outcome: outcome 
   587                                  time: etime - stime
   588                             exception: error
   589                            stacktrace: stack.
   590                      Transcript show:'ERROR'
   591             ]
   592     ].
   593     outcome := nil.
   594     Transcript cr.
   595 
   596     "Created: / 12-01-2012 / 17:43:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   597     "Modified: / 06-06-2014 / 00:54:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"
   598 ! !
   599 
   600 !TestReport class methodsFor:'documentation'!
   601 
   602 version
   603     ^ '$Header$'
   604 !
   605 
   606 version_CVS
   607     ^ '$Header$'
   608 !
   609 
   610 version_SVN
   611     ^ '$Id$'
   612 ! !
   613