"{ Package: 'stx:goodies/builder/reports' }"

"{ NameSpace: Builder }"

ReportFormat subclass:#CoverageReportFormat

	instanceVariableNames:''

	classVariableNames:''

	poolDictionaries:''

	category:'Builder-Reports-Formats'

!

CoverageReportFormat subclass:#Cobertura

	instanceVariableNames:'currentPackage currentClass currentClassLinesBuffer currentMethod

		infos'

	classVariableNames:''

	poolDictionaries:''

	privateIn:CoverageReportFormat

!

Parser subclass:#MethodAnalyzer

	instanceVariableNames:'intervals branches'

	classVariableNames:''

	poolDictionaries:''

	privateIn:CoverageReportFormat::Cobertura

!

!CoverageReportFormat class methodsFor:'testing'!

isAbstract

    ^self == CoverageReportFormat

    "Created: / 04-08-2011 / 11:44:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 25-06-2013 / 01:26:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified (format): / 30-07-2013 / 09:19:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!CoverageReportFormat::Cobertura class methodsFor:'accessing'!

symbolicNames

    "Returns a collection of symbolic names for this format"

    ^ self shouldImplement

! !

!CoverageReportFormat::Cobertura class methodsFor:'documentation'!

documentation

" }

 Replace 'Object', 'NewClass1' and

 the empty string arguments by true values.

 Install (or change) the class by 'accepting',

 either via the menu or the keyboard (usually CMD-A).

 You can also change the category simply by editing

 the categoryString and accepting.

 To be nice to others (and yourself later), do not forget to

 add some documentation; preferably under the classes documentation

 protocol.

 (see the `create documentation stubs' item in the methodList menu;

  switch from instance to class to find this menu item.)

 Notice, that ST/X uses the convention to document the class using

 comment-only class methods (however, ST80 comments are supported and

 can be changed via the class-documentation menu).

"

! !

!CoverageReportFormat::Cobertura methodsFor:'accessing - defaults'!

defaultFileSuffix

    "superclass Builder::ReportFormat says that I am responsible to implement this method"

    ^ 'xml'

    "Modified: / 25-06-2013 / 02:02:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!CoverageReportFormat::Cobertura methodsFor:'private'!

sourceInfoForClass: class inPackage: package

    | infosPerPackage cls |

    cls := class.

    cls isMetaclass ifTrue:[

        cls := cls theNonMetaclass

    ].

    cls isPrivate ifTrue:[

        cls := cls topOwningClass.

    ].

    infosPerPackage := infos at: package ifAbsentPut:[Dictionary new].

    ^ infosPerPackage at: class ifAbsentPut: [ReportSourceInfo forClass: cls inPackage: package].

    "Created: / 29-07-2013 / 18:43:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

sourceInfoForExtensionsinPackage: package

    | infosPerPackage |

    infosPerPackage := infos at: package ifAbsentPut:[Dictionary new].

    ^ infosPerPackage at: 'extensions.st' ifAbsentPut: [ReportSourceInfo forExtensionsInPackage: package].

    "Created: / 29-07-2013 / 18:43:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!CoverageReportFormat::Cobertura methodsFor:'writing'!

write: instrumentedMethods

    | packageMap |

    packageMap := Dictionary new.

    infos := Dictionary new.

    instrumentedMethods do:[:method|

        | classMap methodSet |

        classMap := packageMap at: method package ifAbsentPut: [ Dictionary new ].

        methodSet := classMap at: method mclass theNonMetaclass ifAbsentPut: [ Set new ].

        methodSet add: method.

    ].

    packageMap keys asSortedCollection do:[:package|

        | classMap |            

        self writePackage: package with:[            

            ((classMap := packageMap at: package) keys asSortedCollection:[:a :b| a name < b name ]) do:[:class|

                self writeClass: class with:[

                    | methodSetOrdered |

"/                    methodSetOrdered := (classMap at: class) asSortedCollection:[:a :b | (info offsetOfMethod: a) < (info offsetOfMethod: b)].

                    methodSetOrdered := (classMap at: class) asSortedCollection:[:a :b | a selector < b selector].

                    methodSetOrdered do:[:method|

                        self writeMethod: method.

                    ]                    

                ]

            ]

        ]

    ]

    "Created: / 25-06-2013 / 13:17:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 29-07-2013 / 18:49:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified (format): / 15-12-2014 / 10:21:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

writeClass: class with: content

    | className classFileName classPathName |

    className := class name.

    classFileName := class isPrivate 

                        ifTrue:[(Smalltalk fileNameForClass: class topOwningClass) , '.st']

                        ifFalse:[(Smalltalk fileNameForClass: class) , '.st'].

    class package ~~ currentPackage ifTrue:[

        classFileName := 'extensions.st'

    ].

    classPathName := ((currentPackage copyReplaceAll: $: with: Filename separator) replaceAll: $/ with: Filename separator) 

                        , Filename separator , classFileName.

    stream nextPutAll:'        <class name="'; nextPutAll: className; nextPutAll: '" filename="'; nextPutAll: classPathName; nextPutLine:'" line-rate="1.0" branch-rate="1.0" complexity="1.0">'.

    stream nextPutLine:'          <methods>'.

    currentClass := class.

    currentClassLinesBuffer := String new writeStream.

    content value.               

    currentClass := nil.

    stream nextPutLine:'          </methods>'.

    stream nextPutLine:'          <lines>'.

    stream nextPutAll: currentClassLinesBuffer contents.

    stream nextPutLine:'          </lines>'.

    currentClassLinesBuffer := nil.

    stream nextPutLine:'        </class>'

    "Created: / 25-06-2013 / 12:29:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 27-06-2013 / 00:05:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

writeFooter

    stream nextPutAll:'  </packages>

</coverage>'

    "Modified: / 25-06-2013 / 11:57:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

writeHeader

    stream nextPutAll:'<?xml version="1.0"?>

<!!--DOCTYPE coverage SYSTEM "http://cobertura.sourceforge.net/xml/coverage-03.dtd"-->

<coverage line-rate="1.0" branch-rate="1.0" version="1.9" timestamp="'; nextPutAll: Timestamp now utcSecondsSince1970 printString; nextPutLine:'">'.

    stream nextPutLine:'  <sources>'.

    Smalltalk packagePath do:[:each|

        stream 

            nextPutAll: '<source>';

            nextPutAll: each asFilename asAbsoluteFilename pathName;

            nextPutAll: '</source>';

            cr.                

    ].

    stream nextPutLine:'  </sources>'.

    stream nextPutLine:'  <packages>'.

    "Modified: / 26-06-2013 / 17:50:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

writeLine: lineNr hits: nhits on: s

    s nextPutAll:'            <line number="'; nextPutAll: lineNr printString; nextPutAll:'" hits="'; nextPutAll: nhits printString; nextPutLine:'" branch="false" />'.

    "Created: / 27-06-2013 / 00:03:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

writeMethod: method

    | info firstCharOffset firstLineNr lastLineNr analyzer lines name |

    name := method selector.

    method mclass isMetaclass ifTrue:[

        name := name , ' [class method]'.

    ].

    stream nextPutAll:'        <method name="'; nextPutAll: (self encode: name); nextPutLine: '" signature="" line-rate="1.0" branch-rate="1.0" complexity="1.0">'.

    stream nextPutLine:'          <lines>'.

    currentMethod := method.

    info := method package == method mclass package 

                ifTrue:[self sourceInfoForClass: method mclass inPackage: method package]

                ifFalse:[self sourceInfoForExtensionsinPackage: method package]. 

    firstCharOffset := info offsetOfMethod: method.

    firstLineNr := (info lineAndColumnOfOffset: firstCharOffset) x.

    lastLineNr := (info lineAndColumnOfOffset: firstCharOffset + method source size) x.

    lines := Array new: lastLineNr - firstLineNr + 1 withAll: nil.

    analyzer := MethodAnalyzer new.

    analyzer parseMethod: method source in: method mclass.

    analyzer intervals do:[:interval|

        | start stop |

        start := info lineAndColumnOfOffset: firstCharOffset + interval first - 1.

        stop := info lineAndColumnOfOffset: firstCharOffset + interval last - 1.

        start x to: stop x do:[:lineNr|

            lines at: lineNr - firstLineNr + 1 put: -1.

        ].

    ].

    (method statementInvocationInfo copy sort:[:a :b | a startPosition < b startPosition]) do:[:eachBlockInfo |

        | startLine endLine |

        startLine := (info lineAndColumnOfOffset: firstCharOffset + eachBlockInfo startPosition - 1) x.

        endLine := (info lineAndColumnOfOffset: firstCharOffset + eachBlockInfo endPosition - 1) x.

        startLine to: endLine do:[:lineNr|

            (lines at: (lineNr - firstLineNr + 1)) == -1 ifTrue:[

                lines at: (lineNr - firstLineNr + 1) put: (eachBlockInfo count)

            ] ifFalse:[

                lines at: (lineNr - firstLineNr + 1) put: (((lines at: (lineNr - firstLineNr + 1)) ? (SmallInteger maxVal)) min: eachBlockInfo count)

            ]

        ]            

    ].

    1 to: lines size do:[:i|

        (lines at: i) notNil ifTrue:[

            (lines at: i) == -1 ifTrue:[

                lines at: i put: 0.

            ].

            self writeLine: (i + firstLineNr - 1) hits: ((lines at: i)) on: stream.

            self writeLine: (i + firstLineNr - 1) hits: ((lines at: i)) on: currentClassLinesBuffer.

        ]

    ].

    currentMethod := nil.

    stream nextPutLine:'          </lines>'.

    stream nextPutLine:'        </method>'

    "Created: / 25-06-2013 / 13:17:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 30-07-2013 / 09:12:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

writePackage: packageName with: aBlock

    stream nextPutAll:'    <package name="'; nextPutAll: packageName; nextPutLine: '" line-rate="1.0" branch-rate="1.0" complexity="1.0">'.

    stream nextPutLine:'      <classes>'.

    currentPackage := packageName.

    aBlock value.               

    currentPackage := nil.

    stream nextPutLine:'      </classes>'.

    stream nextPutLine:'    </package>'

    "Created: / 25-06-2013 / 11:55:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 25-06-2013 / 13:24:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!CoverageReportFormat::Cobertura::MethodAnalyzer methodsFor:'accessing'!

branches

    ^ branches

!

intervals

    ^ intervals

! !

!CoverageReportFormat::Cobertura::MethodAnalyzer methodsFor:'code generation hooks'!

statementListRewriteHookFor:aStatementNode

    "invoked whenever a statement list node has been generated;

     gives subclasses a chance to rewrite (instrument) it"

    | stmt |

    intervals isNil ifTrue:[

        intervals := OrderedCollection new.

    ].

    stmt := aStatementNode.

    [ stmt notNil ] whileTrue:[

        intervals add: (stmt startPosition to: stmt endPosition).

        stmt := stmt nextStatement.

    ].

    ^ aStatementNode

    "Created: / 29-07-2013 / 10:16:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 29-07-2013 / 11:25:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!CoverageReportFormat class methodsFor:'documentation'!

version

    ^ '$Header$'

!

version_CVS

    ^ '$Header$'

! !