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