"{ 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|
                | methodSet |
                self writeClass: class with:[
                    | methodSetOrdered info |

"/                    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>"
!

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$'
! !