reports/Builder__CoverageReportFormat.st
author Claus Gittinger <cg@exept.de>
Thu, 28 Mar 2019 13:54:38 +0100
changeset 542 aa25a71be62a
parent 256 2082732c7c0c
permissions -rw-r--r--
#DOCUMENTATION by cg
class: stx_goodies_builder_quickSelfTest
class definition

class: stx_goodies_builder_quickSelfTest class
added:18 methods
jan@167
     1
"{ Package: 'stx:goodies/builder/reports' }"
jan@167
     2
jan@167
     3
"{ NameSpace: Builder }"
jan@167
     4
jan@167
     5
ReportFormat subclass:#CoverageReportFormat
jan@167
     6
	instanceVariableNames:''
jan@167
     7
	classVariableNames:''
jan@167
     8
	poolDictionaries:''
jan@167
     9
	category:'Builder-Reports-Formats'
jan@167
    10
!
jan@167
    11
jan@167
    12
CoverageReportFormat subclass:#Cobertura
jan@183
    13
	instanceVariableNames:'currentPackage currentClass currentClassLinesBuffer currentMethod
jan@183
    14
		infos'
jan@167
    15
	classVariableNames:''
jan@167
    16
	poolDictionaries:''
jan@167
    17
	privateIn:CoverageReportFormat
jan@167
    18
!
jan@167
    19
jan@193
    20
Parser subclass:#MethodAnalyzer
jan@193
    21
	instanceVariableNames:'intervals branches'
jan@193
    22
	classVariableNames:''
jan@193
    23
	poolDictionaries:''
jan@193
    24
	privateIn:CoverageReportFormat::Cobertura
jan@193
    25
!
jan@193
    26
jan@167
    27
jan@167
    28
!CoverageReportFormat class methodsFor:'testing'!
jan@167
    29
jan@167
    30
isAbstract
jan@214
    31
jan@167
    32
    ^self == CoverageReportFormat
jan@167
    33
jan@167
    34
    "Created: / 04-08-2011 / 11:44:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@167
    35
    "Modified: / 25-06-2013 / 01:26:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@214
    36
    "Modified (format): / 30-07-2013 / 09:19:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@167
    37
! !
jan@167
    38
jan@167
    39
!CoverageReportFormat::Cobertura class methodsFor:'accessing'!
jan@167
    40
jan@167
    41
symbolicNames
jan@167
    42
    "Returns a collection of symbolic names for this format"
jan@167
    43
jan@167
    44
    ^ self shouldImplement
jan@167
    45
! !
jan@167
    46
jan@167
    47
!CoverageReportFormat::Cobertura class methodsFor:'documentation'!
jan@167
    48
jan@167
    49
documentation
jan@167
    50
" }
jan@167
    51
jan@167
    52
 Replace 'Object', 'NewClass1' and
jan@167
    53
 the empty string arguments by true values.
jan@167
    54
jan@167
    55
 Install (or change) the class by 'accepting',
jan@167
    56
 either via the menu or the keyboard (usually CMD-A).
jan@167
    57
jan@167
    58
 You can also change the category simply by editing
jan@167
    59
 the categoryString and accepting.
jan@167
    60
jan@167
    61
 To be nice to others (and yourself later), do not forget to
jan@167
    62
 add some documentation; preferably under the classes documentation
jan@167
    63
 protocol.
jan@167
    64
 (see the `create documentation stubs' item in the methodList menu;
jan@167
    65
  switch from instance to class to find this menu item.)
jan@167
    66
jan@167
    67
 Notice, that ST/X uses the convention to document the class using
jan@167
    68
 comment-only class methods (however, ST80 comments are supported and
jan@167
    69
 can be changed via the class-documentation menu).
jan@167
    70
jan@167
    71
"
jan@167
    72
! !
jan@167
    73
jan@167
    74
!CoverageReportFormat::Cobertura methodsFor:'accessing - defaults'!
jan@167
    75
jan@167
    76
defaultFileSuffix
jan@167
    77
    "superclass Builder::ReportFormat says that I am responsible to implement this method"
jan@167
    78
jan@167
    79
    ^ 'xml'
jan@167
    80
jan@167
    81
    "Modified: / 25-06-2013 / 02:02:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@167
    82
! !
jan@167
    83
jan@213
    84
!CoverageReportFormat::Cobertura methodsFor:'private'!
jan@213
    85
jan@213
    86
sourceInfoForClass: class inPackage: package
jan@213
    87
    | infosPerPackage cls |
jan@213
    88
jan@213
    89
    cls := class.
jan@213
    90
    cls isMetaclass ifTrue:[
jan@213
    91
        cls := cls theNonMetaclass
jan@213
    92
    ].
jan@213
    93
    cls isPrivate ifTrue:[
jan@213
    94
        cls := cls topOwningClass.
jan@213
    95
    ].
jan@213
    96
    infosPerPackage := infos at: package ifAbsentPut:[Dictionary new].
jan@213
    97
    ^ infosPerPackage at: class ifAbsentPut: [ReportSourceInfo forClass: cls inPackage: package].
jan@213
    98
jan@213
    99
    "Created: / 29-07-2013 / 18:43:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@213
   100
!
jan@213
   101
jan@213
   102
sourceInfoForExtensionsinPackage: package
jan@213
   103
    | infosPerPackage |
jan@213
   104
jan@213
   105
    infosPerPackage := infos at: package ifAbsentPut:[Dictionary new].
jan@213
   106
    ^ infosPerPackage at: 'extensions.st' ifAbsentPut: [ReportSourceInfo forExtensionsInPackage: package].
jan@213
   107
jan@213
   108
    "Created: / 29-07-2013 / 18:43:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@213
   109
! !
jan@213
   110
jan@167
   111
!CoverageReportFormat::Cobertura methodsFor:'writing'!
jan@167
   112
jan@167
   113
write: instrumentedMethods
jan@167
   114
    | packageMap |
jan@167
   115
jan@167
   116
    packageMap := Dictionary new.
jan@167
   117
    infos := Dictionary new.
jan@167
   118
    instrumentedMethods do:[:method|
jan@183
   119
        | classMap methodSet |
jan@167
   120
        classMap := packageMap at: method package ifAbsentPut: [ Dictionary new ].
jan@186
   121
        methodSet := classMap at: method mclass theNonMetaclass ifAbsentPut: [ Set new ].
jan@183
   122
        methodSet add: method.
jan@167
   123
    ].
jan@167
   124
jan@167
   125
    packageMap keys asSortedCollection do:[:package|
jan@167
   126
        | classMap |            
jan@167
   127
jan@167
   128
        self writePackage: package with:[            
jan@167
   129
            ((classMap := packageMap at: package) keys asSortedCollection:[:a :b| a name < b name ]) do:[:class|
jan@167
   130
                self writeClass: class with:[
jan@256
   131
                    | methodSetOrdered |
jan@167
   132
jan@213
   133
"/                    methodSetOrdered := (classMap at: class) asSortedCollection:[:a :b | (info offsetOfMethod: a) < (info offsetOfMethod: b)].
jan@213
   134
                    methodSetOrdered := (classMap at: class) asSortedCollection:[:a :b | a selector < b selector].
jan@183
   135
                    methodSetOrdered do:[:method|
jan@167
   136
                        self writeMethod: method.
jan@167
   137
                    ]                    
jan@167
   138
                ]
jan@167
   139
            ]
jan@167
   140
        ]
jan@167
   141
    ]
jan@167
   142
jan@167
   143
    "Created: / 25-06-2013 / 13:17:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@213
   144
    "Modified: / 29-07-2013 / 18:49:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@256
   145
    "Modified (format): / 15-12-2014 / 10:21:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@167
   146
!
jan@167
   147
jan@167
   148
writeClass: class with: content
jan@167
   149
jan@167
   150
    | className classFileName classPathName |
jan@167
   151
jan@167
   152
    className := class name.
jan@167
   153
    classFileName := class isPrivate 
jan@182
   154
                        ifTrue:[(Smalltalk fileNameForClass: class topOwningClass) , '.st']
jan@182
   155
                        ifFalse:[(Smalltalk fileNameForClass: class) , '.st'].
jan@167
   156
    class package ~~ currentPackage ifTrue:[
jan@167
   157
        classFileName := 'extensions.st'
jan@167
   158
    ].
jan@167
   159
    classPathName := ((currentPackage copyReplaceAll: $: with: Filename separator) replaceAll: $/ with: Filename separator) 
jan@167
   160
                        , Filename separator , classFileName.
jan@167
   161
jan@167
   162
    stream nextPutAll:'        <class name="'; nextPutAll: className; nextPutAll: '" filename="'; nextPutAll: classPathName; nextPutLine:'" line-rate="1.0" branch-rate="1.0" complexity="1.0">'.
jan@167
   163
    stream nextPutLine:'          <methods>'.
jan@167
   164
    currentClass := class.
jan@183
   165
    currentClassLinesBuffer := String new writeStream.
jan@167
   166
    content value.               
jan@167
   167
    currentClass := nil.
jan@167
   168
    stream nextPutLine:'          </methods>'.
jan@183
   169
    stream nextPutLine:'          <lines>'.
jan@183
   170
    stream nextPutAll: currentClassLinesBuffer contents.
jan@183
   171
    stream nextPutLine:'          </lines>'.
jan@183
   172
    currentClassLinesBuffer := nil.
jan@167
   173
    stream nextPutLine:'        </class>'
jan@167
   174
jan@167
   175
    "Created: / 25-06-2013 / 12:29:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@183
   176
    "Modified: / 27-06-2013 / 00:05:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@167
   177
!
jan@167
   178
jan@167
   179
writeFooter
jan@167
   180
    stream nextPutAll:'  </packages>
jan@167
   181
</coverage>'
jan@167
   182
jan@167
   183
    "Modified: / 25-06-2013 / 11:57:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@167
   184
!
jan@167
   185
jan@167
   186
writeHeader
jan@167
   187
    stream nextPutAll:'<?xml version="1.0"?>
jan@167
   188
<!!--DOCTYPE coverage SYSTEM "http://cobertura.sourceforge.net/xml/coverage-03.dtd"-->
jan@167
   189
jan@182
   190
<coverage line-rate="1.0" branch-rate="1.0" version="1.9" timestamp="'; nextPutAll: Timestamp now utcSecondsSince1970 printString; nextPutLine:'">'.
jan@182
   191
    stream nextPutLine:'  <sources>'.
jan@182
   192
    Smalltalk packagePath do:[:each|
jan@182
   193
        stream 
jan@182
   194
            nextPutAll: '<source>';
jan@182
   195
            nextPutAll: each asFilename asAbsoluteFilename pathName;
jan@182
   196
            nextPutAll: '</source>';
jan@182
   197
            cr.                
jan@182
   198
    ].
jan@182
   199
    stream nextPutLine:'  </sources>'.
jan@182
   200
    stream nextPutLine:'  <packages>'.
jan@167
   201
jan@182
   202
    "Modified: / 26-06-2013 / 17:50:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@167
   203
!
jan@167
   204
jan@183
   205
writeLine: lineNr hits: nhits on: s
jan@167
   206
jan@183
   207
    s nextPutAll:'            <line number="'; nextPutAll: lineNr printString; nextPutAll:'" hits="'; nextPutAll: nhits printString; nextPutLine:'" branch="false" />'.
jan@167
   208
jan@183
   209
    "Created: / 27-06-2013 / 00:03:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@167
   210
!
jan@167
   211
jan@167
   212
writeMethod: method
jan@167
   213
jan@193
   214
    | info firstCharOffset firstLineNr lastLineNr analyzer lines name |
jan@167
   215
jan@186
   216
    name := method selector.
jan@186
   217
    method mclass isMetaclass ifTrue:[
jan@186
   218
        name := name , ' [class method]'.
jan@186
   219
    ].
jan@186
   220
jan@214
   221
    stream nextPutAll:'        <method name="'; nextPutAll: (self encode: name); nextPutLine: '" signature="" line-rate="1.0" branch-rate="1.0" complexity="1.0">'.
jan@167
   222
    stream nextPutLine:'          <lines>'.
jan@167
   223
    currentMethod := method.
jan@167
   224
jan@213
   225
    info := method package == method mclass package 
jan@213
   226
                ifTrue:[self sourceInfoForClass: method mclass inPackage: method package]
jan@213
   227
                ifFalse:[self sourceInfoForExtensionsinPackage: method package]. 
jan@213
   228
jan@167
   229
    firstCharOffset := info offsetOfMethod: method.
jan@167
   230
    firstLineNr := (info lineAndColumnOfOffset: firstCharOffset) x.
jan@167
   231
    lastLineNr := (info lineAndColumnOfOffset: firstCharOffset + method source size) x.
jan@167
   232
jan@192
   233
    lines := Array new: lastLineNr - firstLineNr + 1 withAll: nil.
jan@193
   234
    analyzer := MethodAnalyzer new.
jan@193
   235
    analyzer parseMethod: method source in: method mclass.
jan@193
   236
    analyzer intervals do:[:interval|
jan@193
   237
        | start stop |
jan@213
   238
        start := info lineAndColumnOfOffset: firstCharOffset + interval first - 1.
jan@213
   239
        stop := info lineAndColumnOfOffset: firstCharOffset + interval last - 1.
jan@193
   240
        start x to: stop x do:[:lineNr|
jan@213
   241
            lines at: lineNr - firstLineNr + 1 put: -1.
jan@193
   242
        ].
jan@193
   243
    ].
jan@167
   244
jan@192
   245
    (method statementInvocationInfo copy sort:[:a :b | a startPosition < b startPosition]) do:[:eachBlockInfo |
jan@167
   246
        | startLine endLine |
jan@167
   247
jan@167
   248
        startLine := (info lineAndColumnOfOffset: firstCharOffset + eachBlockInfo startPosition - 1) x.
jan@167
   249
        endLine := (info lineAndColumnOfOffset: firstCharOffset + eachBlockInfo endPosition - 1) x.
jan@167
   250
        startLine to: endLine do:[:lineNr|
jan@213
   251
jan@193
   252
            (lines at: (lineNr - firstLineNr + 1)) == -1 ifTrue:[
jan@192
   253
                lines at: (lineNr - firstLineNr + 1) put: (eachBlockInfo count)
jan@192
   254
            ] ifFalse:[
jan@213
   255
                lines at: (lineNr - firstLineNr + 1) put: (((lines at: (lineNr - firstLineNr + 1)) ? (SmallInteger maxVal)) min: eachBlockInfo count)
jan@192
   256
            ]
jan@167
   257
        ]            
jan@167
   258
    ].
jan@167
   259
    1 to: lines size do:[:i|
jan@193
   260
        (lines at: i) notNil ifTrue:[
jan@193
   261
            (lines at: i) == -1 ifTrue:[
jan@193
   262
                lines at: i put: 0.
jan@193
   263
            ].
jan@193
   264
            self writeLine: (i + firstLineNr - 1) hits: ((lines at: i)) on: stream.
jan@193
   265
            self writeLine: (i + firstLineNr - 1) hits: ((lines at: i)) on: currentClassLinesBuffer.
jan@193
   266
        ]
jan@167
   267
    ].
jan@167
   268
jan@167
   269
    currentMethod := nil.
jan@167
   270
    stream nextPutLine:'          </lines>'.
jan@167
   271
    stream nextPutLine:'        </method>'
jan@167
   272
jan@167
   273
    "Created: / 25-06-2013 / 13:17:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@214
   274
    "Modified: / 30-07-2013 / 09:12:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@167
   275
!
jan@167
   276
jan@167
   277
writePackage: packageName with: aBlock
jan@167
   278
jan@167
   279
    stream nextPutAll:'    <package name="'; nextPutAll: packageName; nextPutLine: '" line-rate="1.0" branch-rate="1.0" complexity="1.0">'.
jan@167
   280
    stream nextPutLine:'      <classes>'.
jan@167
   281
    currentPackage := packageName.
jan@167
   282
    aBlock value.               
jan@167
   283
    currentPackage := nil.
jan@167
   284
    stream nextPutLine:'      </classes>'.
jan@167
   285
    stream nextPutLine:'    </package>'
jan@167
   286
jan@167
   287
    "Created: / 25-06-2013 / 11:55:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@167
   288
    "Modified: / 25-06-2013 / 13:24:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@167
   289
! !
jan@167
   290
jan@193
   291
!CoverageReportFormat::Cobertura::MethodAnalyzer methodsFor:'accessing'!
jan@193
   292
jan@193
   293
branches
jan@193
   294
    ^ branches
jan@193
   295
!
jan@193
   296
jan@193
   297
intervals
jan@193
   298
    ^ intervals
jan@193
   299
! !
jan@193
   300
jan@193
   301
!CoverageReportFormat::Cobertura::MethodAnalyzer methodsFor:'code generation hooks'!
jan@193
   302
jan@193
   303
statementListRewriteHookFor:aStatementNode
jan@193
   304
    "invoked whenever a statement list node has been generated;
jan@193
   305
     gives subclasses a chance to rewrite (instrument) it"
jan@193
   306
jan@193
   307
    | stmt |
jan@193
   308
jan@193
   309
    intervals isNil ifTrue:[
jan@193
   310
        intervals := OrderedCollection new.
jan@193
   311
    ].
jan@193
   312
    stmt := aStatementNode.
jan@193
   313
    [ stmt notNil ] whileTrue:[
jan@193
   314
        intervals add: (stmt startPosition to: stmt endPosition).
jan@193
   315
        stmt := stmt nextStatement.
jan@193
   316
    ].
jan@193
   317
    ^ aStatementNode
jan@193
   318
jan@193
   319
    "Created: / 29-07-2013 / 10:16:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@193
   320
    "Modified: / 29-07-2013 / 11:25:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
jan@193
   321
! !
jan@193
   322
jan@167
   323
!CoverageReportFormat class methodsFor:'documentation'!
jan@167
   324
jan@167
   325
version
jan@167
   326
    ^ '$Header$'
jan@167
   327
!
jan@167
   328
jan@167
   329
version_CVS
jan@167
   330
    ^ '$Header$'
jan@167
   331
! !
jan@167
   332